2010-09-09 21:47:19 +00:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
|
|
|
|
|
|
|
|
-- |
|
|
|
|
-- Module : Network.TLS.Receiving
|
|
|
|
-- License : BSD-style
|
|
|
|
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : unknown
|
|
|
|
--
|
|
|
|
-- the Receiving module contains calls related to unmarshalling packets according
|
|
|
|
-- to the TLS state
|
|
|
|
--
|
|
|
|
module Network.TLS.Receiving (
|
|
|
|
readPacket
|
|
|
|
) where
|
|
|
|
|
2010-10-02 21:02:37 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2010-09-09 21:47:19 +00:00
|
|
|
import Control.Monad.State
|
|
|
|
import Control.Monad.Error
|
|
|
|
import Data.Maybe
|
|
|
|
|
2010-09-26 09:34:47 +00:00
|
|
|
import Data.ByteString (ByteString)
|
2010-09-09 21:47:19 +00:00
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import qualified Data.ByteString as B
|
|
|
|
|
2010-09-26 17:51:23 +00:00
|
|
|
import Network.TLS.Util
|
2010-09-26 13:57:35 +00:00
|
|
|
import Network.TLS.Cap
|
2010-09-09 21:47:19 +00:00
|
|
|
import Network.TLS.Struct
|
|
|
|
import Network.TLS.Packet
|
|
|
|
import Network.TLS.State
|
|
|
|
import Network.TLS.Cipher
|
|
|
|
import Network.TLS.Crypto
|
|
|
|
import Network.TLS.SRandom
|
|
|
|
import Data.Certificate.X509
|
|
|
|
|
|
|
|
newtype TLSRead a = TLSR { runTLSR :: ErrorT TLSError (State TLSState) a }
|
|
|
|
deriving (Monad, MonadError TLSError)
|
|
|
|
|
|
|
|
instance Functor TLSRead where
|
|
|
|
fmap f = TLSR . fmap f . runTLSR
|
|
|
|
|
|
|
|
instance MonadTLSState TLSRead where
|
|
|
|
putTLSState x = TLSR (lift $ put x)
|
|
|
|
getTLSState = TLSR (lift get)
|
|
|
|
|
|
|
|
runTLSRead :: MonadTLSState m => TLSRead a -> m (Either TLSError a)
|
|
|
|
runTLSRead f = do
|
|
|
|
st <- getTLSState
|
|
|
|
let (a, newst) = runState (runErrorT (runTLSR f)) st
|
|
|
|
putTLSState newst
|
|
|
|
return a
|
|
|
|
|
|
|
|
returnEither :: Either TLSError a -> TLSRead a
|
|
|
|
returnEither (Left err) = throwError err
|
|
|
|
returnEither (Right a) = return a
|
|
|
|
|
2010-10-02 21:41:00 +00:00
|
|
|
readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError [Packet])
|
2010-10-02 21:02:37 +00:00
|
|
|
readPacket hdr content = runTLSRead (checkState hdr >> decryptContent hdr content >>= processPacket hdr)
|
|
|
|
|
|
|
|
checkState :: Header -> TLSRead ()
|
|
|
|
checkState (Header pt _ _) =
|
|
|
|
stStatus <$> getTLSState >>= \status -> unless (allowed pt status) $ throwError $ Error_Packet_unexpected (show status) (show pt)
|
|
|
|
where
|
|
|
|
allowed :: ProtocolType -> TLSStatus -> Bool
|
|
|
|
allowed ProtocolType_Alert _ = True
|
|
|
|
allowed ProtocolType_Handshake _ = True
|
|
|
|
allowed ProtocolType_AppData StatusHandshakeReq = True
|
|
|
|
allowed ProtocolType_AppData StatusOk = True
|
|
|
|
allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientFinished) = True
|
|
|
|
allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientKeyXchg) = True
|
|
|
|
allowed ProtocolType_ChangeCipherSpec (StatusHandshake HsStatusClientCertificateVerify) = True
|
|
|
|
allowed _ _ = False
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-10-02 21:41:00 +00:00
|
|
|
processPacket :: Header -> Bytes -> TLSRead [Packet]
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-10-02 21:41:00 +00:00
|
|
|
processPacket (Header ProtocolType_AppData _ _) content = return [AppData content]
|
2010-10-02 08:09:46 +00:00
|
|
|
|
2010-10-02 21:41:00 +00:00
|
|
|
processPacket (Header ProtocolType_Alert _ _) content = return . (:[]) . Alert =<< returnEither (decodeAlert content)
|
2010-10-02 08:09:46 +00:00
|
|
|
|
|
|
|
processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
|
2010-10-02 21:02:37 +00:00
|
|
|
e <- updateStatusCC False
|
|
|
|
when (isJust e) $ throwError (fromJust e)
|
|
|
|
|
2010-10-02 08:09:46 +00:00
|
|
|
returnEither $ decodeChangeCipherSpec content
|
2010-09-09 21:47:19 +00:00
|
|
|
switchRxEncryption
|
|
|
|
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
2010-10-02 21:41:00 +00:00
|
|
|
return [ChangeCipherSpec]
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-10-02 08:09:46 +00:00
|
|
|
processPacket (Header ProtocolType_Handshake ver _) dcontent = do
|
2010-10-02 09:34:45 +00:00
|
|
|
handshakes <- returnEither (decodeHandshakes dcontent)
|
2010-10-02 21:41:00 +00:00
|
|
|
forM handshakes $ \(ty, content) -> do
|
2010-10-02 09:34:45 +00:00
|
|
|
hs <- processHandshake ver ty content
|
|
|
|
when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content
|
|
|
|
return hs
|
|
|
|
|
|
|
|
processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet
|
|
|
|
processHandshake ver ty econtent = do
|
2010-10-02 08:09:46 +00:00
|
|
|
-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
|
2010-10-02 21:02:37 +00:00
|
|
|
e <- updateStatusHs ty
|
|
|
|
when (isJust e) $ throwError (fromJust e)
|
|
|
|
|
2010-10-02 08:09:46 +00:00
|
|
|
content <- case ty of
|
|
|
|
HandshakeType_ClientKeyXchg -> do
|
|
|
|
copt <- decryptRSA econtent
|
|
|
|
return $ maybe econtent id copt
|
|
|
|
_ ->
|
|
|
|
return econtent
|
|
|
|
hs <- case (ty, decodeHandshake ver ty content) of
|
|
|
|
(_, Right x) -> return x
|
|
|
|
(HandshakeType_ClientKeyXchg, Left _) -> return $ ClientKeyXchg SSL2 (ClientKeyData $ B.replicate 46 0xff)
|
|
|
|
(_, Left err) -> throwError err
|
|
|
|
clientmode <- isClientContext
|
|
|
|
case hs of
|
|
|
|
ClientHello cver ran _ _ _ _ -> unless clientmode $ do
|
|
|
|
startHandshakeClient cver ran
|
|
|
|
ServerHello sver ran _ _ _ _ -> when clientmode $ do
|
|
|
|
setServerRandom ran
|
|
|
|
setVersion sver
|
|
|
|
Certificates certs -> when clientmode $ do processCertificates certs
|
|
|
|
ClientKeyXchg cver _ -> unless clientmode $ do
|
|
|
|
processClientKeyXchg cver content
|
|
|
|
Finished fdata -> processClientFinished fdata
|
|
|
|
_ -> return ()
|
|
|
|
return $ Handshake hs
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)
|
|
|
|
decryptRSA econtent = do
|
|
|
|
rsapriv <- getTLSState >>= return . fromJust . hstRSAPrivateKey . fromJust . stHandshake
|
2010-09-26 09:34:47 +00:00
|
|
|
return $ rsaDecrypt rsapriv (B.drop 2 econtent)
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
setMasterSecretRandom :: ByteString -> TLSRead ()
|
|
|
|
setMasterSecretRandom content = do
|
|
|
|
st <- getTLSState
|
2010-09-26 09:34:47 +00:00
|
|
|
let (bytes, g') = getRandomBytes (stRandomGen st) (fromIntegral $ B.length content)
|
2010-09-09 21:47:19 +00:00
|
|
|
putTLSState $ st { stRandomGen = g' }
|
2010-09-26 09:34:47 +00:00
|
|
|
setMasterSecret (B.pack bytes)
|
2010-09-09 21:47:19 +00:00
|
|
|
|
|
|
|
processClientKeyXchg :: Version -> ByteString -> TLSRead ()
|
|
|
|
processClientKeyXchg ver content = do
|
|
|
|
{- the TLS protocol expect the initial client version received in the ClientHello, not the negociated version -}
|
|
|
|
expectedVer <- getTLSState >>= return . hstClientVersion . fromJust . stHandshake
|
|
|
|
if expectedVer /= ver
|
|
|
|
then setMasterSecretRandom content
|
|
|
|
else setMasterSecret content
|
|
|
|
|
|
|
|
processClientFinished :: FinishedData -> TLSRead ()
|
|
|
|
processClientFinished fdata = do
|
|
|
|
cc <- getTLSState >>= return . stClientContext
|
|
|
|
expected <- getHandshakeDigest (not cc)
|
2010-09-26 09:34:47 +00:00
|
|
|
when (expected /= B.pack fdata) $ do
|
2010-09-09 21:47:19 +00:00
|
|
|
-- FIXME don't fail, but report the error so that the code can send a BadMac Alert.
|
|
|
|
fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))
|
|
|
|
return ()
|
|
|
|
|
|
|
|
decryptContent :: Header -> EncryptedData -> TLSRead ByteString
|
|
|
|
decryptContent hdr e@(EncryptedData b) = do
|
|
|
|
st <- getTLSState
|
|
|
|
if stRxEncrypted st
|
2010-09-26 19:56:04 +00:00
|
|
|
then decryptData e >>= getCipherData hdr
|
2010-09-09 21:47:19 +00:00
|
|
|
else return b
|
|
|
|
|
2010-09-26 19:56:04 +00:00
|
|
|
getCipherData :: Header -> CipherData -> TLSRead ByteString
|
|
|
|
getCipherData hdr cdata = do
|
|
|
|
-- check if the MAC is valid.
|
|
|
|
macValid <- case cipherDataMAC cdata of
|
|
|
|
Nothing -> return True
|
|
|
|
Just digest -> do
|
|
|
|
let (Header pt ver _) = hdr
|
|
|
|
let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)
|
|
|
|
expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata
|
|
|
|
if expected_digest == digest
|
|
|
|
then return True
|
|
|
|
else return False
|
|
|
|
|
|
|
|
-- check if the padding is filled with the correct pattern if it exists
|
|
|
|
paddingValid <- case cipherDataPadding cdata of
|
|
|
|
Nothing -> return True
|
|
|
|
Just pad -> do
|
|
|
|
let b = B.length pad - 1
|
|
|
|
return $ maybe True (const False) $ B.find (/= fromIntegral b) pad
|
|
|
|
|
|
|
|
unless (and $! [ macValid, paddingValid ]) $ do
|
|
|
|
throwError $ Error_Digest ([], [])
|
|
|
|
|
|
|
|
return $ cipherDataContent cdata
|
|
|
|
|
|
|
|
decryptData :: EncryptedData -> TLSRead CipherData
|
2010-09-09 21:47:19 +00:00
|
|
|
decryptData (EncryptedData econtent) = do
|
|
|
|
st <- getTLSState
|
|
|
|
|
|
|
|
assert "decrypt data"
|
|
|
|
[ ("cipher", isNothing $ stCipher st)
|
|
|
|
, ("crypt state", isNothing $ stRxCryptState st) ]
|
|
|
|
|
2010-09-26 19:56:04 +00:00
|
|
|
let cipher = fromJust $ stCipher st
|
|
|
|
let cst = fromJust $ stRxCryptState st
|
2010-09-09 21:47:19 +00:00
|
|
|
let padding_size = fromIntegral $ cipherPaddingSize cipher
|
2010-09-26 19:56:04 +00:00
|
|
|
let digestSize = fromIntegral $ cipherDigestSize cipher
|
|
|
|
let writekey = cstKey cst
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-09-26 19:56:04 +00:00
|
|
|
case cipherF cipher of
|
2010-09-09 21:47:19 +00:00
|
|
|
CipherNoneF -> fail "none decrypt"
|
|
|
|
CipherBlockF _ decryptF -> do
|
|
|
|
{- update IV -}
|
2010-09-26 13:57:35 +00:00
|
|
|
let (iv, econtent') =
|
|
|
|
if hasExplicitBlockIV $ stVersion st
|
2010-09-26 19:56:04 +00:00
|
|
|
then B.splitAt (fromIntegral $ cipherIVSize cipher) econtent
|
|
|
|
else (cstIV cst, econtent)
|
2010-09-26 17:51:23 +00:00
|
|
|
let newiv = fromJust $ takelast padding_size econtent'
|
2010-09-09 21:47:19 +00:00
|
|
|
putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }
|
2010-09-26 19:56:04 +00:00
|
|
|
|
|
|
|
let content' = decryptF writekey iv econtent'
|
|
|
|
let paddinglength = fromIntegral (B.last content') + 1
|
|
|
|
let contentlen = B.length content' - paddinglength - digestSize
|
|
|
|
let (content, mac, padding) = fromJust $ partition3 content' (contentlen, digestSize, paddinglength)
|
|
|
|
return $ CipherData
|
|
|
|
{ cipherDataContent = content
|
|
|
|
, cipherDataMAC = Just mac
|
|
|
|
, cipherDataPadding = Just padding
|
|
|
|
}
|
2010-09-09 21:47:19 +00:00
|
|
|
CipherStreamF initF _ decryptF -> do
|
2010-09-26 13:57:35 +00:00
|
|
|
let iv = cstIV cst
|
2010-09-26 19:56:04 +00:00
|
|
|
let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent
|
2010-09-09 21:47:19 +00:00
|
|
|
{- update Ctx -}
|
2010-09-26 19:56:04 +00:00
|
|
|
let contentlen = B.length content' - digestSize
|
|
|
|
let (content, mac, _) = fromJust $ partition3 content' (contentlen, digestSize, 0)
|
2010-09-26 09:34:47 +00:00
|
|
|
putTLSState $ st { stRxCryptState = Just $ cst { cstIV = newiv } }
|
2010-09-26 19:56:04 +00:00
|
|
|
return $ CipherData
|
|
|
|
{ cipherDataContent = content
|
|
|
|
, cipherDataMAC = Just mac
|
|
|
|
, cipherDataPadding = Nothing
|
|
|
|
}
|
2010-09-09 21:47:19 +00:00
|
|
|
|
2010-09-18 10:00:07 +00:00
|
|
|
processCertificates :: [Certificate] -> TLSRead ()
|
|
|
|
processCertificates certs = do
|
|
|
|
case certPubKey $ head certs of
|
2010-09-09 21:47:19 +00:00
|
|
|
PubKey _ (PubKeyRSA (lm, m, e)) -> do
|
|
|
|
let pk = PublicKey { public_size = fromIntegral lm, public_n = m, public_e = e }
|
|
|
|
setPublicKey pk
|
|
|
|
_ -> return ()
|