refactorize receiving packet thing
This commit is contained in:
parent
0c1dfe0837
commit
d188a180cc
1 changed files with 35 additions and 40 deletions
|
@ -14,7 +14,6 @@ module Network.TLS.Receiving (
|
||||||
readPacket
|
readPacket
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.Error
|
import Control.Monad.Error
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
@ -55,21 +54,47 @@ returnEither (Left err) = throwError err
|
||||||
returnEither (Right a) = return a
|
returnEither (Right a) = return a
|
||||||
|
|
||||||
readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet)
|
readPacket :: MonadTLSState m => Header -> EncryptedData -> m (Either TLSError Packet)
|
||||||
readPacket hdr@(Header ProtocolType_AppData _ _) content =
|
readPacket hdr content = runTLSRead (decryptContent hdr content >>= processPacket hdr)
|
||||||
runTLSRead (AppData <$> decryptContent hdr content)
|
|
||||||
|
|
||||||
readPacket hdr@(Header ProtocolType_Alert _ _) content =
|
processPacket :: Header -> Bytes -> TLSRead Packet
|
||||||
runTLSRead (decryptContent hdr content >>= returnEither . decodeAlert >>= return . Alert)
|
|
||||||
|
|
||||||
readPacket hdr@(Header ProtocolType_ChangeCipherSpec _ _) content = runTLSRead $ do
|
processPacket (Header ProtocolType_AppData _ _) content = return $ AppData content
|
||||||
dcontent <- decryptContent hdr content
|
|
||||||
returnEither $ decodeChangeCipherSpec dcontent
|
processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlert content)
|
||||||
|
|
||||||
|
processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
|
||||||
|
returnEither $ decodeChangeCipherSpec content
|
||||||
switchRxEncryption
|
switchRxEncryption
|
||||||
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
||||||
return ChangeCipherSpec
|
return ChangeCipherSpec
|
||||||
|
|
||||||
readPacket hdr@(Header ProtocolType_Handshake ver _) content =
|
processPacket (Header ProtocolType_Handshake ver _) dcontent = do
|
||||||
runTLSRead (decryptContent hdr content >>= processHsPacket ver)
|
(ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent
|
||||||
|
-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
|
||||||
|
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 ()
|
||||||
|
when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent)
|
||||||
|
return $ Handshake hs
|
||||||
|
|
||||||
decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)
|
decryptRSA :: MonadTLSState m => ByteString -> m (Maybe ByteString)
|
||||||
decryptRSA econtent = do
|
decryptRSA econtent = do
|
||||||
|
@ -100,36 +125,6 @@ processClientFinished fdata = do
|
||||||
fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))
|
fail ("client mac failure: expecting " ++ show expected ++ " received " ++ (show $L.pack fdata))
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
processHsPacket :: Version -> ByteString -> TLSRead Packet
|
|
||||||
processHsPacket ver dcontent = do
|
|
||||||
(ty, econtent) <- returnEither $ decodeHandshakeHeader dcontent
|
|
||||||
-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
|
|
||||||
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 ()
|
|
||||||
when (finishHandshakeTypeMaterial ty) (updateHandshakeDigest dcontent)
|
|
||||||
return $ Handshake hs
|
|
||||||
|
|
||||||
|
|
||||||
decryptContent :: Header -> EncryptedData -> TLSRead ByteString
|
decryptContent :: Header -> EncryptedData -> TLSRead ByteString
|
||||||
decryptContent hdr e@(EncryptedData b) = do
|
decryptContent hdr e@(EncryptedData b) = do
|
||||||
st <- getTLSState
|
st <- getTLSState
|
||||||
|
|
Loading…
Reference in a new issue