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
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Error
|
||||
import Data.Maybe
|
||||
|
@ -54,7 +55,21 @@ returnEither (Left err) = throwError err
|
|||
returnEither (Right a) = return a
|
||||
|
||||
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
|
||||
|
||||
|
@ -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_ChangeCipherSpec _ _) content = do
|
||||
e <- updateStatusCC False
|
||||
when (isJust e) $ throwError (fromJust e)
|
||||
|
||||
returnEither $ decodeChangeCipherSpec content
|
||||
switchRxEncryption
|
||||
isClientContext >>= \cc -> when (not cc) setKeyBlock
|
||||
|
@ -79,6 +97,9 @@ processPacket (Header ProtocolType_Handshake ver _) dcontent = do
|
|||
processHandshake :: Version -> HandshakeType -> ByteString -> TLSRead Packet
|
||||
processHandshake ver ty econtent = do
|
||||
-- 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
|
||||
HandshakeType_ClientKeyXchg -> do
|
||||
copt <- decryptRSA econtent
|
||||
|
|
|
@ -76,13 +76,24 @@ postprocessPacketData dat = return dat
|
|||
encodePacket :: MonadTLSState m => (Header, ByteString) -> m ByteString
|
||||
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
|
||||
- and updating state on the go
|
||||
-}
|
||||
writePacket :: MonadTLSState m => Packet -> m ByteString
|
||||
writePacket pkt = makePacketData pkt >>= processPacketData >>=
|
||||
writePacket pkt = preProcessPacket pkt >>= makePacketData >>= processPacketData >>=
|
||||
encryptPacketData >>= postprocessPacketData >>= encodePacket
|
||||
|
||||
{------------------------------------------------------------------------------}
|
||||
|
|
|
@ -18,6 +18,8 @@ module Network.TLS.State
|
|||
, MonadTLSState, getTLSState, putTLSState, modifyTLSState
|
||||
, newTLSState
|
||||
, assert -- FIXME move somewhere else (Internal.hs ?)
|
||||
, updateStatusHs
|
||||
, updateStatusCC
|
||||
, finishHandshakeTypeMaterial
|
||||
, finishHandshakeMaterial
|
||||
, makeDigest
|
||||
|
@ -39,6 +41,7 @@ module Network.TLS.State
|
|||
) where
|
||||
|
||||
import Data.Word
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromJust, isNothing)
|
||||
import Network.TLS.Util
|
||||
import Network.TLS.Struct
|
||||
|
@ -67,7 +70,6 @@ data HandshakeStatus =
|
|||
| HsStatusClientChangeCipher
|
||||
| HsStatusClientFinished
|
||||
| HsStatusServerChangeCipher
|
||||
| HsStatusServerFinished
|
||||
deriving (Show,Eq)
|
||||
|
||||
data TLSStatus =
|
||||
|
@ -154,6 +156,68 @@ makeDigest w hdr content = do
|
|||
modifyTLSState (\_ -> if w then st { stTxMacState = Just newms } else st { stRxMacState = Just newms })
|
||||
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_ClientHello = True
|
||||
finishHandshakeTypeMaterial HandshakeType_ServerHello = True
|
||||
|
|
|
@ -103,6 +103,7 @@ data TLSError =
|
|||
| Error_Digest ([Word8], [Word8])
|
||||
| Error_Packet String
|
||||
| Error_Packet_Size_Mismatch (Int, Int)
|
||||
| Error_Packet_unexpected String String
|
||||
| Error_Internal_Packet_Remaining Int
|
||||
| Error_Internal_Packet_ByteProcessed Int Int Int
|
||||
| Error_Unknown_Version Word8 Word8
|
||||
|
|
Loading…
Reference in a new issue