new state machine
This commit is contained in:
parent
5a6ff3abe8
commit
e189f37a67
4 changed files with 100 additions and 3 deletions
|
@ -14,6 +14,7 @@ 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
|
||||||
|
@ -54,7 +55,21 @@ 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 content = runTLSRead (decryptContent hdr content >>= processPacket hdr)
|
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
|
||||||
|
|
||||||
processPacket :: Header -> Bytes -> TLSRead Packet
|
processPacket :: Header -> Bytes -> TLSRead Packet
|
||||||
|
|
||||||
|
@ -63,6 +78,9 @@ processPacket (Header ProtocolType_AppData _ _) content = return $ AppData conte
|
||||||
processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlert content)
|
processPacket (Header ProtocolType_Alert _ _) content = return . Alert =<< returnEither (decodeAlert content)
|
||||||
|
|
||||||
processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
|
processPacket (Header ProtocolType_ChangeCipherSpec _ _) content = do
|
||||||
|
e <- updateStatusCC False
|
||||||
|
when (isJust e) $ throwError (fromJust e)
|
||||||
|
|
||||||
returnEither $ decodeChangeCipherSpec content
|
returnEither $ decodeChangeCipherSpec content
|
||||||
switchRxEncryption
|
switchRxEncryption
|
||||||
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
||||||
|
@ -79,6 +97,9 @@ processPacket (Header ProtocolType_Handshake ver _) dcontent = do
|
||||||
processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet
|
processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet
|
||||||
processHandshake ver ty econtent = do
|
processHandshake ver ty econtent = do
|
||||||
-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
|
-- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.
|
||||||
|
e <- updateStatusHs ty
|
||||||
|
when (isJust e) $ throwError (fromJust e)
|
||||||
|
|
||||||
content <- case ty of
|
content <- case ty of
|
||||||
HandshakeType_ClientKeyXchg -> do
|
HandshakeType_ClientKeyXchg -> do
|
||||||
copt <- decryptRSA econtent
|
copt <- decryptRSA econtent
|
||||||
|
|
|
@ -76,13 +76,24 @@ postprocessPacketData dat = return dat
|
||||||
encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString
|
encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString
|
||||||
encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]
|
encodePacket (hdr, content) = return $ B.concat [ encodeHeader hdr, content ]
|
||||||
|
|
||||||
|
{-
|
||||||
|
- just update TLS state machine
|
||||||
|
-}
|
||||||
|
preProcessPacket :: MonadTLSState m => Packet -> m Packet
|
||||||
|
preProcessPacket pkt = do
|
||||||
|
e <- case pkt of
|
||||||
|
Handshake hs -> updateStatusHs (typeOfHandshake hs)
|
||||||
|
AppData _ -> return Nothing
|
||||||
|
ChangeCipherSpec -> updateStatusCC True
|
||||||
|
Alert _ -> return Nothing
|
||||||
|
return pkt
|
||||||
|
|
||||||
{-
|
{-
|
||||||
- writePacket transform a packet into marshalled data related to current state
|
- writePacket transform a packet into marshalled data related to current state
|
||||||
- and updating state on the go
|
- and updating state on the go
|
||||||
-}
|
-}
|
||||||
writePacket :: MonadTLSState m => Packet -> m ByteString
|
writePacket :: MonadTLSState m => Packet -> m ByteString
|
||||||
writePacket pkt = makePacketData pkt >>= processPacketData >>=
|
writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>=
|
||||||
encryptPacketData >>= postprocessPacketData >>= encodePacket
|
encryptPacketData >>= postprocessPacketData >>= encodePacket
|
||||||
|
|
||||||
{------------------------------------------------------------------------------}
|
{------------------------------------------------------------------------------}
|
||||||
|
|
|
@ -18,6 +18,8 @@ module Network.TLS.State
|
||||||
, MonadTLSState, getTLSState, putTLSState, modifyTLSState
|
, MonadTLSState, getTLSState, putTLSState, modifyTLSState
|
||||||
, newTLSState
|
, newTLSState
|
||||||
, assert -- FIXME move somewhere else (Internal.hs ?)
|
, assert -- FIXME move somewhere else (Internal.hs ?)
|
||||||
|
, updateStatusHs
|
||||||
|
, updateStatusCC
|
||||||
, finishHandshakeTypeMaterial
|
, finishHandshakeTypeMaterial
|
||||||
, finishHandshakeMaterial
|
, finishHandshakeMaterial
|
||||||
, makeDigest
|
, makeDigest
|
||||||
|
@ -39,6 +41,7 @@ module Network.TLS.State
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
import Data.List (find)
|
||||||
import Data.Maybe (fromJust, isNothing)
|
import Data.Maybe (fromJust, isNothing)
|
||||||
import Network.TLS.Util
|
import Network.TLS.Util
|
||||||
import Network.TLS.Struct
|
import Network.TLS.Struct
|
||||||
|
@ -67,7 +70,6 @@ data HandshakeStatus =
|
||||||
| HsStatusClientChangeCipher
|
| HsStatusClientChangeCipher
|
||||||
| HsStatusClientFinished
|
| HsStatusClientFinished
|
||||||
| HsStatusServerChangeCipher
|
| HsStatusServerChangeCipher
|
||||||
| HsStatusServerFinished
|
|
||||||
deriving (Show,Eq)
|
deriving (Show,Eq)
|
||||||
|
|
||||||
data TLSStatus =
|
data TLSStatus =
|
||||||
|
@ -154,6 +156,68 @@ makeDigest w hdr content = do
|
||||||
modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })
|
modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })
|
||||||
return digest
|
return digest
|
||||||
|
|
||||||
|
hsStatusTransitionTable :: [ (HandshakeType, TLSStatus, [ TLSStatus ]) ]
|
||||||
|
hsStatusTransitionTable =
|
||||||
|
[ (HandshakeType_HelloRequest, StatusHandshakeReq,
|
||||||
|
[ StatusOk ])
|
||||||
|
, (HandshakeType_ClientHello, StatusHandshake HsStatusClientHello,
|
||||||
|
[ StatusInit, StatusHandshakeReq ])
|
||||||
|
, (HandshakeType_ServerHello, StatusHandshake HsStatusServerHello,
|
||||||
|
[ StatusHandshake HsStatusClientHello ])
|
||||||
|
, (HandshakeType_Certificate, StatusHandshake HsStatusServerCertificate,
|
||||||
|
[ StatusHandshake HsStatusServerHello ])
|
||||||
|
, (HandshakeType_ServerKeyXchg, StatusHandshake HsStatusServerKeyXchg,
|
||||||
|
[ StatusHandshake HsStatusServerHello
|
||||||
|
, StatusHandshake HsStatusServerCertificate ])
|
||||||
|
, (HandshakeType_CertRequest, StatusHandshake HsStatusServerCertificateReq,
|
||||||
|
[ StatusHandshake HsStatusServerHello
|
||||||
|
, StatusHandshake HsStatusServerCertificate
|
||||||
|
, StatusHandshake HsStatusServerKeyXchg ])
|
||||||
|
, (HandshakeType_ServerHelloDone, StatusHandshake HsStatusServerHelloDone,
|
||||||
|
[ StatusHandshake HsStatusServerHello
|
||||||
|
, StatusHandshake HsStatusServerCertificate
|
||||||
|
, StatusHandshake HsStatusServerKeyXchg
|
||||||
|
, StatusHandshake HsStatusServerCertificateReq ])
|
||||||
|
, (HandshakeType_Certificate, StatusHandshake HsStatusClientCertificate,
|
||||||
|
[ StatusHandshake HsStatusServerHelloDone ])
|
||||||
|
, (HandshakeType_ClientKeyXchg, StatusHandshake HsStatusClientKeyXchg,
|
||||||
|
[ StatusHandshake HsStatusServerHelloDone
|
||||||
|
, StatusHandshake HsStatusClientCertificate ])
|
||||||
|
, (HandshakeType_CertVerify, StatusHandshake HsStatusClientCertificateVerify,
|
||||||
|
[ StatusHandshake HsStatusClientKeyXchg ])
|
||||||
|
, (HandshakeType_Finished, StatusHandshake HsStatusClientFinished,
|
||||||
|
[ StatusHandshake HsStatusClientChangeCipher ])
|
||||||
|
, (HandshakeType_Finished, StatusOk,
|
||||||
|
[ StatusHandshake HsStatusServerChangeCipher ])
|
||||||
|
]
|
||||||
|
|
||||||
|
updateStatus :: MonadTLSState m => TLSStatus -> m ()
|
||||||
|
updateStatus x = modifyTLSState (\st -> st { stStatus = x })
|
||||||
|
|
||||||
|
updateStatusHs :: MonadTLSState m => HandshakeType -> m (Maybe TLSError)
|
||||||
|
updateStatusHs ty = do
|
||||||
|
status <- return . stStatus =<< getTLSState
|
||||||
|
ns <- return . transition . stStatus =<< getTLSState
|
||||||
|
case ns of
|
||||||
|
Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("handshake:" ++ show ty)
|
||||||
|
Just (_,x,_) -> updateStatus x >> return Nothing
|
||||||
|
where
|
||||||
|
edgeEq cur (ety, _, aprevs) = ty == ety && (maybe False (const True) $ find (== cur) aprevs)
|
||||||
|
transition currentStatus = find (edgeEq currentStatus) hsStatusTransitionTable
|
||||||
|
|
||||||
|
updateStatusCC :: MonadTLSState m => Bool -> m (Maybe TLSError)
|
||||||
|
updateStatusCC sending = do
|
||||||
|
status <- return . stStatus =<< getTLSState
|
||||||
|
cc <- isClientContext
|
||||||
|
let x = case (cc /= sending, status) of
|
||||||
|
(False, StatusHandshake HsStatusClientKeyXchg) -> Just (StatusHandshake HsStatusClientChangeCipher)
|
||||||
|
(False, StatusHandshake HsStatusClientCertificateVerify) -> Just (StatusHandshake HsStatusClientChangeCipher)
|
||||||
|
(True, StatusHandshake HsStatusClientFinished) -> Just (StatusHandshake HsStatusServerChangeCipher)
|
||||||
|
_ -> Nothing
|
||||||
|
case x of
|
||||||
|
Just newstatus -> updateStatus newstatus >> return Nothing
|
||||||
|
Nothing -> return $ Just $ Error_Packet_unexpected (show status) ("Client Context: " ++ show cc)
|
||||||
|
|
||||||
finishHandshakeTypeMaterial :: HandshakeType -> Bool
|
finishHandshakeTypeMaterial :: HandshakeType -> Bool
|
||||||
finishHandshakeTypeMaterial HandshakeType_ClientHello = True
|
finishHandshakeTypeMaterial HandshakeType_ClientHello = True
|
||||||
finishHandshakeTypeMaterial HandshakeType_ServerHello = True
|
finishHandshakeTypeMaterial HandshakeType_ServerHello = True
|
||||||
|
|
|
@ -103,6 +103,7 @@ data TLSError =
|
||||||
| Error_Digest ([Word8], [Word8])
|
| Error_Digest ([Word8], [Word8])
|
||||||
| Error_Packet String
|
| Error_Packet String
|
||||||
| Error_Packet_Size_Mismatch (Int, Int)
|
| Error_Packet_Size_Mismatch (Int, Int)
|
||||||
|
| Error_Packet_unexpected String String
|
||||||
| Error_Internal_Packet_Remaining Int
|
| Error_Internal_Packet_Remaining Int
|
||||||
| Error_Internal_Packet_ByteProcessed Int Int Int
|
| Error_Internal_Packet_ByteProcessed Int Int Int
|
||||||
| Error_Unknown_Version Word8 Word8
|
| Error_Unknown_Version Word8 Word8
|
||||||
|
|
Loading…
Reference in a new issue