tls 0.8.3 → 0.8.3.1
raw patch · 13 files changed
+540/−690 lines, 13 filesdep −cprng-aesdep −time
Dependencies removed: cprng-aes, time
Files
- Network/TLS/Core.hs +87/−165
- Network/TLS/Measurement.hs +0/−46
- Network/TLS/Packet.hs +25/−28
- Network/TLS/Receiving.hs +148/−25
- Network/TLS/Record.hs +74/−10
- Network/TLS/Record/Disengage.hs +0/−117
- Network/TLS/Record/Engage.hs +0/−89
- Network/TLS/Record/Types.hs +0/−96
- Network/TLS/Sending.hs +88/−4
- Network/TLS/State.hs +97/−0
- Network/TLS/Struct.hs +4/−3
- Tests.hs +15/−98
- tls.cabal +2/−9
Network/TLS/Core.hs view
@@ -11,7 +11,6 @@ -- * Context configuration TLSParams(..) , TLSLogging(..)- , Measurement(..) , TLSCertificateUsage(..) , TLSCertificateRejectReason(..) , defaultLogging@@ -50,7 +49,6 @@ import Network.TLS.State import Network.TLS.Sending import Network.TLS.Receiving-import Network.TLS.Measurement import Data.Maybe import Data.Certificate.X509 import Data.List (intersect, intercalate, find)@@ -98,7 +96,6 @@ , pUseSecureRenegotiation :: Bool -- notify that we want to use secure renegotation , pCertificates :: [(X509, Maybe PrivateKey)] -- ^ the cert chain for this context with the associated keys if any. , pLogging :: TLSLogging -- ^ callback for logging- , onHandshake :: Measurement -> IO Bool -- ^ callback on a beggining of handshake , onCertificatesRecv :: [X509] -> IO TLSCertificateUsage -- ^ callback to verify received cert chain. } @@ -120,7 +117,6 @@ , pUseSecureRenegotiation = True , pCertificates = [] , pLogging = defaultLogging- , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept) } @@ -139,27 +135,20 @@ { ctxConnection :: a -- ^ return the connection object associated with this context , ctxParams :: TLSParams , ctxState :: MVar TLSState- , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ is the handle has EOFed or not. , ctxConnectionFlush :: IO () , ctxConnectionSend :: Bytes -> IO () , ctxConnectionRecv :: Int -> IO Bytes } -updateMeasure :: MonadIO m => TLSCtx c -> (Measurement -> Measurement) -> m ()-updateMeasure ctx f = liftIO $ modifyIORef (ctxMeasurement ctx) f--withMeasure :: MonadIO m => TLSCtx c -> (Measurement -> IO a) -> m a-withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f)- connectionFlush :: TLSCtx c -> IO ()-connectionFlush c = ctxConnectionFlush c+connectionFlush c = (ctxConnectionFlush c) connectionSend :: TLSCtx c -> Bytes -> IO ()-connectionSend c b = updateMeasure c (addBytesSent $ B.length b) >> (ctxConnectionSend c) b+connectionSend c b = (ctxConnectionSend c) b connectionRecv :: TLSCtx c -> Int -> IO Bytes-connectionRecv c sz = updateMeasure c (addBytesReceived sz) >> (ctxConnectionRecv c) sz+connectionRecv c sz = (ctxConnectionRecv c) sz ctxEOF :: MonadIO m => TLSCtx a -> m Bool ctxEOF ctx = liftIO (readIORef $ ctxEOF_ ctx)@@ -171,13 +160,11 @@ newCtxWith c flushF sendF recvF params st = do stvar <- newMVar st eof <- newIORef False- stats <- newIORef newMeasurement return $ TLSCtx- { ctxConnection = c- , ctxParams = params- , ctxState = stvar- , ctxMeasurement = stats- , ctxEOF_ = eof+ { ctxConnection = c+ , ctxParams = params+ , ctxState = stvar+ , ctxEOF_ = eof , ctxConnectionFlush = flushF , ctxConnectionSend = sendF , ctxConnectionRecv = recvF@@ -210,6 +197,11 @@ getStateRNG :: MonadIO m => TLSCtx c -> Int -> m Bytes getStateRNG ctx n = usingState_ ctx (genTLSRandom n) +whileStatus :: MonadIO m => TLSCtx c -> (TLSStatus -> Bool) -> m a -> m ()+whileStatus ctx p a = do+ b <- usingState_ ctx (p . stStatus <$> get)+ when b (a >> whileStatus ctx p a)+ errorToAlert :: TLSError -> Packet errorToAlert (Error_Protocol (_, _, ad)) = Alert [(AlertLevel_Fatal, ad)] errorToAlert _ = Alert [(AlertLevel_Fatal, InternalError)]@@ -227,67 +219,33 @@ else throwCore (Error_Packet ("partial packet: expecting " ++ show sz ++ " bytes, got: " ++ (show $B.length hdrbs))) return hdrbs -recvRecord :: MonadIO m => TLSCtx c -> m (Either TLSError (Record Plaintext))-recvRecord ctx = readExact ctx 5 >>= either (return . Left) recvLength . decodeHeader- where recvLength header@(Header _ _ readlen)- | readlen > 16384 + 2048 = return $ Left $ Error_Protocol ("record exceeding maximum size", True, RecordOverflow)- | otherwise = do- content <- readExact ctx (fromIntegral readlen)- liftIO $ (loggingIORecv $ ctxLogging ctx) header content- usingState ctx $ disengageRecord $ rawToRecord header (fragmentCiphertext content)-- -- | receive one packet from the context that contains 1 or -- many messages (many only in case of handshake). if will returns a -- TLSError if the packet is unexpected or malformed recvPacket :: MonadIO m => TLSCtx c -> m (Either TLSError Packet) recvPacket ctx = do- erecord <- recvRecord ctx- case erecord of- Left err -> return $ Left err- Right record -> do- pkt <- usingState ctx $ processPacket record- case pkt of- Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p- _ -> return ()- return pkt--recvPacketHandshake :: MonadIO m => TLSCtx c -> m [Handshake]-recvPacketHandshake ctx = do- pkts <- recvPacket ctx- case pkts of- Right (Handshake l) -> return l- Right x -> fail ("unexpected type received. expecting handshake and got: " ++ show x)- Left err -> throwCore err--data RecvState m =- RecvStateNext (Packet -> m (RecvState m))- | RecvStateHandshake (Handshake -> m (RecvState m))- | RecvStateDone--runRecvState :: MonadIO m => TLSCtx a -> RecvState m -> m ()-runRecvState _ (RecvStateDone) = return ()-runRecvState ctx (RecvStateNext f) = recvPacket ctx >>= either throwCore f >>= runRecvState ctx-runRecvState ctx iniState = recvPacketHandshake ctx >>= loop iniState >>= runRecvState ctx- where- loop :: MonadIO m => RecvState m -> [Handshake] -> m (RecvState m)- loop recvState [] = return recvState- loop (RecvStateHandshake f) (x:xs) = do- nstate <- f x- usingState_ ctx $ processHandshake x- loop nstate xs- loop _ _ = unexpected "spurious handshake" Nothing--sendChangeCipherAndFinish :: MonadIO m => TLSCtx c -> Bool -> m ()-sendChangeCipherAndFinish ctx isClient = do- sendPacket ctx ChangeCipherSpec- liftIO $ connectionFlush ctx- cf <- usingState_ ctx $ getHandshakeDigest isClient- sendPacket ctx (Handshake [Finished cf])- liftIO $ connectionFlush ctx+ hdrbs <- readExact ctx 5+ case decodeHeader hdrbs of+ Left err -> return $ Left err+ Right header@(Header _ _ readlen) ->+ if readlen > (16384 + 2048)+ then return $ Left $ Error_Protocol ("record exceeding maximum size",True, RecordOverflow)+ else recvLength header readlen+ where recvLength header readlen = do+ content <- readExact ctx (fromIntegral readlen)+ liftIO $ (loggingIORecv $ ctxLogging ctx) header content+ pkt <- usingState ctx $ readPacket $ rawToRecord header (fragmentCiphertext content)+ case pkt of+ Right p -> liftIO $ (loggingPacketRecv $ ctxLogging ctx) $ show p+ _ -> return ()+ return pkt -unexpected :: MonadIO m => String -> Maybe [Char] -> m a-unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected)+recvPacketSuccess :: MonadIO m => TLSCtx c -> m ()+recvPacketSuccess ctx = do+ pkt <- recvPacket ctx+ case pkt of+ Left err -> throwCore err+ Right _ -> return () -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx c -> Packet -> m ()@@ -333,14 +291,41 @@ -- values intertwined with response from the server. handshakeClient :: MonadIO m => TLSCtx c -> m () handshakeClient ctx = do- updateMeasure ctx incrementNbHandshakes- sendClientHello- recvServerHello- sendCertificate >> sendClientKeyXchg >> sendCertificateVerify- sendChangeCipherAndFinish ctx True- recvChangeCipherAndFinish- updateMeasure ctx resetBytesCounters+ -- Send ClientHello+ crand <- getStateRNG ctx 32 >>= return . ClientRandom+ extensions <- getExtensions+ usingState_ ctx (startHandshakeClient ver crand)+ sendPacket ctx $ Handshake+ [ ClientHello ver crand (Session Nothing) (map cipherID ciphers)+ (map compressionID compressions) extensions+ ] + -- Receive Server information until ServerHelloDone+ whileStatus ctx (/= (StatusHandshake HsStatusServerHelloDone)) $ do+ pkts <- recvPacket ctx+ case pkts of+ Left err -> throwCore err+ Right l -> processServerInfo l++ -- Send Certificate if requested. XXX disabled for now.+ certRequested <- return False+ when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])++ sendClientKeyXchg++ {- maybe send certificateVerify -}+ {- FIXME not implemented yet -}++ sendPacket ctx ChangeCipherSpec+ liftIO $ connectionFlush ctx++ -- Send Finished+ cf <- usingState_ ctx $ getHandshakeDigest True+ sendPacket ctx (Handshake [Finished cf])++ -- receive changeCipherSpec & Finished+ recvPacketSuccess ctx >> recvPacketSuccess ctx >> return ()+ where params = ctxParams ctx ver = pConnectVersion params@@ -353,36 +338,10 @@ then usingState_ ctx (getVerifiedData True) >>= \vd -> return [ (0xff01, encodeExtSecureRenegotiation vd Nothing) ] else return [] - sendClientHello = do- crand <- getStateRNG ctx 32 >>= return . ClientRandom- extensions <- getExtensions- usingState_ ctx (startHandshakeClient ver crand)- sendPacket ctx $ Handshake- [ ClientHello ver crand (Session Nothing) (map cipherID ciphers)- (map compressionID compressions) extensions- ]-- recvChangeCipherAndFinish = runRecvState ctx (RecvStateNext expectChangeCipher)- where- expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish- expectChangeCipher p = unexpected (show p) (Just "change cipher")- expectFinish (Finished _) = return RecvStateDone- expectFinish p = unexpected (show p) (Just "Handshake Finished")-- sendCertificate = do- -- Send Certificate if requested. XXX disabled for now.- certRequested <- return False- when certRequested (sendPacket ctx $ Handshake [Certificates clientCerts])-- sendCertificateVerify =- {- maybe send certificateVerify -}- {- FIXME not implemented yet -}- return ()-- recvServerHello = runRecvState ctx (RecvStateHandshake processServerHello)+ processServerInfo (Handshake hss) = mapM_ processHandshake hss+ processServerInfo _ = return () - processServerHello :: MonadIO m => Handshake -> m (RecvState m)- processServerHello (ServerHello rver _ _ cipher _ _) = do+ processHandshake (ServerHello rver _ _ cipher _ _) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) case find ((==) rver) allowedvers of Nothing -> throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)@@ -390,39 +349,22 @@ case find ((==) cipher . cipherID) ciphers of Nothing -> throwCore $ Error_Protocol ("no cipher in common with the server", True, HandshakeFailure) Just c -> usingState_ ctx $ setCipher c- return $ RecvStateHandshake processCertificate- processServerHello p = unexpected (show p) (Just "server hello") - processCertificate :: MonadIO m => Handshake -> m (RecvState m)- processCertificate (Certificates certs) = do+ processHandshake (Certificates certs) = do let cb = onCertificatesRecv $ params usage <- liftIO $ cb certs case usage of CertificateUsageAccept -> return () CertificateUsageReject reason -> certificateRejected reason- return $ RecvStateHandshake processServerKeyExchange- processCertificate p = processServerKeyExchange p - processServerKeyExchange :: MonadIO m => Handshake -> m (RecvState m)- processServerKeyExchange (ServerKeyXchg _) = return $ RecvStateHandshake processCertificateRequest- processServerKeyExchange p = processCertificateRequest p-- processCertificateRequest (CertRequest _ _ _) = do+ processHandshake (CertRequest _ _ _) = do+ return () --modify (\sc -> sc { scCertRequested = True })- return $ RecvStateHandshake processServerHelloDone- processCertificateRequest p = processServerHelloDone p-- processServerHelloDone ServerHelloDone = return RecvStateDone- processServerHelloDone p = unexpected (show p) (Just "server hello data")+ processHandshake _ = return () sendClientKeyXchg = do- encryptedPreMaster <- usingState_ ctx $ do- xver <- stVersion <$> get- prerand <- genTLSRandom 46- let premaster = encodePreMasterSecret xver prerand- setMasterSecret premaster- encryptRSA premaster- sendPacket ctx $ Handshake [ClientKeyXchg encryptedPreMaster]+ prerand <- getStateRNG ctx 46 >>= return . ClientKeyData+ sendPacket ctx $ Handshake [ClientKeyXchg ver prerand] -- on certificate reject, throw an exception with the proper protocol alert error. certificateRejected CertificateRejectRevoked =@@ -435,14 +377,8 @@ throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()-handshakeServerWith ctx clientHello@(ClientHello ver _ _ ciphers compressions _) = do- -- check if policy allow this new handshake to happens- handshakeAuthorized <- withMeasure ctx (onHandshake $ ctxParams ctx)- unless handshakeAuthorized (throwCore $ Error_HandshakePolicy "server: handshake denied")- updateMeasure ctx incrementNbHandshakes-+handshakeServerWith ctx (ClientHello ver _ _ ciphers compressions _) = do -- Handle Client hello- usingState_ ctx $ processHandshake clientHello when (ver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) when (not $ elem ver (pAllowedVersions params)) $ throwCore $ Error_Protocol ("version " ++ show ver ++ "is not supported", True, ProtocolVersion)@@ -461,10 +397,15 @@ liftIO $ connectionFlush ctx -- Receive client info until client Finished.- recvClientData- sendChangeCipherAndFinish ctx False+ whileStatus ctx (/= (StatusHandshake HsStatusClientFinished)) (recvPacketSuccess ctx) - updateMeasure ctx resetBytesCounters+ sendPacket ctx ChangeCipherSpec++ -- Send Finish+ cf <- usingState_ ctx $ getHandshakeDigest False+ sendPacket ctx (Handshake [Finished cf])++ liftIO $ connectionFlush ctx return () where params = ctxParams ctx@@ -476,25 +417,6 @@ privKeys = map snd $ pCertificates params needKeyXchg = cipherExchangeNeedMoreData $ cipherKeyExchange usedCipher - ---- recvClientData = runRecvState ctx (RecvStateHandshake $ processClientCertificate)-- processClientCertificate (Certificates _) = return $ RecvStateHandshake processClientKeyExchange- processClientCertificate p = processClientKeyExchange p-- processClientKeyExchange (ClientKeyXchg _) = return $ RecvStateNext processCertificateVerify- processClientKeyExchange p = unexpected (show p) (Just "client key exchange")-- processCertificateVerify (Handshake [CertVerify _]) = return $ RecvStateNext expectChangeCipher- processCertificateVerify p = expectChangeCipher p-- expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish- expectChangeCipher p = unexpected (show p) (Just "change cipher")-- expectFinish (Finished _) = return RecvStateDone- expectFinish p = unexpected (show p) (Just "Handshake Finished")- ---- handshakeSendServerData = do srand <- getStateRNG ctx 32 >>= return . ServerRandom @@ -534,7 +456,7 @@ handshakeServerWith _ _ = fail "unexpected handshake type received. expecting client hello" --- after receiving a client hello, we need to redo a handshake+-- after receiving a client hello, we need to redo a handshake -} handshakeServer :: MonadIO m => TLSCtx c -> m () handshakeServer ctx = do pkts <- recvPacket ctx@@ -552,7 +474,7 @@ handleException f = catch (f >> return True) (\e -> handler e >> return False) handler e = case fromException e of Just err -> sendPacket ctx (errorToAlert err)- Nothing -> sendPacket ctx (errorToAlert $ Error_Misc $ show e)+ Nothing -> sendPacket ctx (errorToAlert $ Error_Misc "") -- | sendData sends a bunch of data. -- It will automatically chunk data to acceptable packet size
− Network/TLS/Measurement.hs
@@ -1,46 +0,0 @@--- |--- Module : Network.TLS.Measurement--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown----module Network.TLS.Measurement- ( Measurement(..)- , newMeasurement- , addBytesReceived- , addBytesSent- , resetBytesCounters- , incrementNbHandshakes- ) where--import Data.Word---- | record some data about this connection.-data Measurement = Measurement- { nbHandshakes :: !Word32 -- ^ number of handshakes on this context- , bytesReceived :: !Word32 -- ^ bytes received since last handshake- , bytesSent :: !Word32 -- ^ bytes sent since last handshake- } deriving (Show,Eq)--newMeasurement :: Measurement-newMeasurement = Measurement- { nbHandshakes = 0- , bytesReceived = 0- , bytesSent = 0- }--addBytesReceived :: Int -> Measurement -> Measurement-addBytesReceived sz measure =- measure { bytesReceived = bytesReceived measure + fromIntegral sz }--addBytesSent :: Int -> Measurement -> Measurement-addBytesSent sz measure =- measure { bytesSent = bytesSent measure + fromIntegral sz }--resetBytesCounters :: Measurement -> Measurement-resetBytesCounters measure = measure { bytesReceived = 0, bytesSent = 0 }--incrementNbHandshakes :: Measurement -> Measurement-incrementNbHandshakes measure =- measure { nbHandshakes = nbHandshakes measure + 1 }
Network/TLS/Packet.hs view
@@ -35,9 +35,6 @@ , decodeChangeCipherSpec , encodeChangeCipherSpec - , decodePreMasterSecret- , encodePreMasterSecret- -- * marshall extensions , decodeExtSecureRenegotiation , encodeExtSecureRenegotiation@@ -250,7 +247,10 @@ return $ CertVerify [] decodeClientKeyXchg :: Get Handshake-decodeClientKeyXchg = ClientKeyXchg <$> (remaining >>= getBytes)+decodeClientKeyXchg = do+ ver <- getVersion+ ran <- getClientKeyData46+ return $ ClientKeyXchg ver ran os2ip :: ByteString -> Integer os2ip = B.foldl' (\a b -> (256 * a) .|. (fromIntegral b)) 0@@ -269,20 +269,18 @@ return $ ServerRSAParams { rsa_modulus = os2ip modulus, rsa_exponent = os2ip expo } decodeServerKeyXchg :: CurrentParams -> Get Handshake-decodeServerKeyXchg cp = ServerKeyXchg <$> case cParamsKeyXchgType cp of- CipherKeyExchange_RSA -> SKX_RSA . Just <$> decodeServerKeyXchg_RSA- CipherKeyExchange_DH_Anon -> SKX_DH_Anon <$> decodeServerKeyXchg_DH- CipherKeyExchange_DHE_RSA -> do- dhparams <- decodeServerKeyXchg_DH- signature <- getWord16 >>= getBytes . fromIntegral- return $ SKX_DHE_RSA dhparams (B.unpack signature)- CipherKeyExchange_DHE_DSS -> do- dhparams <- decodeServerKeyXchg_DH- signature <- getWord16 >>= getBytes . fromIntegral- return $ SKX_DHE_DSS dhparams (B.unpack signature)- _ -> do- bs <- remaining >>= getBytes- return $ SKX_Unknown bs+decodeServerKeyXchg cp = do+ skxAlg <- case cParamsKeyXchgType cp of+ CipherKeyExchange_RSA -> do+ rsaparams <- decodeServerKeyXchg_RSA+ return $ SKX_RSA $ Just rsaparams+ CipherKeyExchange_DH_Anon -> do+ dhparams <- decodeServerKeyXchg_DH+ return $ SKX_DH_Anon dhparams+ _ -> do+ bs <- remaining >>= getBytes+ return $ SKX_Unknown bs+ return (ServerKeyXchg skxAlg) encodeHandshake :: Handshake -> ByteString encodeHandshake o =@@ -319,8 +317,9 @@ certbs = runPut $ mapM_ putCert certs len = fromIntegral $ B.length certbs -encodeHandshakeContent (ClientKeyXchg content) = do- putBytes content+encodeHandshakeContent (ClientKeyXchg version random) = do+ putVersion version+ putClientKeyData46 random encodeHandshakeContent (ServerKeyXchg _) = do -- FIXME@@ -359,6 +358,12 @@ putServerRandom32 :: ServerRandom -> Put putServerRandom32 (ServerRandom r) = putRandom32 r +getClientKeyData46 :: Get ClientKeyData+getClientKeyData46 = ClientKeyData <$> getBytes 46++putClientKeyData46 :: ClientKeyData -> Put+putClientKeyData46 (ClientKeyData d) = putBytes d+ getSession :: Get Session getSession = do len8 <- getWord8@@ -435,14 +440,6 @@ putWord8 $ fromIntegral (B.length cvd + B.length svd) putBytes cvd putBytes svd---- rsa pre master secret-decodePreMasterSecret :: Bytes -> Either TLSError (Version, Bytes)-decodePreMasterSecret = runGetErr "pre-master-secret" $ do- liftM2 (,) getVersion (getBytes 46)--encodePreMasterSecret :: Version -> Bytes -> Bytes-encodePreMasterSecret version bytes = runPut (putVersion version >> putBytes bytes) {- - generate things for packet content
Network/TLS/Receiving.hs view
@@ -8,20 +8,26 @@ -- the Receiving module contains calls related to unmarshalling packets according -- to the TLS state ---module Network.TLS.Receiving (processHandshake, processPacket) where+module Network.TLS.Receiving (+ readPacket+ ) where +import Data.Maybe (isJust) import Control.Applicative ((<$>)) import Control.Monad.State import Control.Monad.Error import Data.ByteString (ByteString)+import qualified Data.ByteString as B import Network.TLS.Util+import Network.TLS.Cap import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.Crypto import Data.Certificate.X509 @@ -29,6 +35,25 @@ returnEither (Left err) = throwError err returnEither (Right a) = return a +readPacket :: Record Ciphertext -> TLSSt Packet+readPacket record = checkState record >> decryptContent record >>= uncompressContent >>= processPacket++checkState :: Record a -> TLSSt ()+checkState (Record pt _ _) =+ stStatus <$> get >>= \status -> unless (allowed pt status) $ throwError (err status)+ where+ err st = Error_Protocol ("unexpected message received: status=" ++ show st, True, UnexpectedMessage)++ 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 :: Record Plaintext -> TLSSt Packet processPacket (Record ProtocolType_AppData _ fragment) = return $ AppData $ fragmentGetBytes fragment@@ -36,26 +61,40 @@ processPacket (Record ProtocolType_Alert _ fragment) = return . Alert =<< returnEither (decodeAlerts $ fragmentGetBytes fragment) processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do+ e <- updateStatusCC False+ when (isJust e) $ throwError (fromJust "" e)+ returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment switchRxEncryption isClientContext >>= \cc -> when (not cc) setKeyBlock return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do+ handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)+ hss <- forM handshakes $ \(ty, content) -> do+ hs <- processHandshake ver ty content+ when (finishHandshakeTypeMaterial ty) $ updateHandshakeDigestSplitted ty content+ return hs+ return $ Handshake hss++processHandshake :: Version -> HandshakeType -> ByteString -> TLSSt Handshake+processHandshake ver ty econtent = do+ -- SECURITY FIXME if RSA fail, we need to generate a random master secret and not fail.+ e <- updateStatusHs ty+ maybe (return ()) throwError e+ keyxchg <- getCipherKeyExchangeType let currentparams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = maybe CipherKeyExchange_RSA id $ keyxchg }- handshakes <- returnEither (decodeHandshakes $ fragmentGetBytes fragment)- hss <- forM handshakes $ \(ty, content) -> do- case decodeHandshake currentparams ty content of- Left err -> throwError err- Right hs -> return hs- return $ Handshake hss--processHandshake :: Handshake -> TLSSt ()-processHandshake hs = do+ content <- case ty of+ HandshakeType_ClientKeyXchg -> either (const econtent) id <$> decryptRSA econtent+ _ -> return econtent+ hs <- case (ty, decodeHandshake currentparams 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 _ _ _ ex -> unless clientmode $ do@@ -69,11 +108,11 @@ setServerRandom ran setVersion sver Certificates certs -> when clientmode $ do processCertificates certs- ClientKeyXchg content -> unless clientmode $ do- processClientKeyXchg content+ ClientKeyXchg cver _ -> unless clientmode $ do+ processClientKeyXchg cver content Finished fdata -> processClientFinished fdata _ -> return ()- when (finishHandshakeTypeMaterial $ typeOfHandshake hs) (updateHandshakeDigest $ encodeHandshake hs)+ return hs where -- secure renegotiation processClientExtension (0xff01, content) = do@@ -96,24 +135,20 @@ decryptRSA :: ByteString -> TLSSt (Either KxError ByteString) decryptRSA econtent = do+ ver <- stVersion <$> get rsapriv <- fromJust "rsa private key" . hstRSAPrivateKey . fromJust "handshake" . stHandshake <$> get- return $ kxDecrypt rsapriv econtent+ return $ kxDecrypt rsapriv (if ver < TLS10 then econtent else B.drop 2 econtent) -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negociated version. -- in case the version mismatch, generate a random master secret-processClientKeyXchg :: ByteString -> TLSSt ()-processClientKeyXchg encryptedPremaster = do+processClientKeyXchg :: Version -> ByteString -> TLSSt ()+processClientKeyXchg ver content = do expectedVer <- hstClientVersion . fromJust "handshake" . stHandshake <$> get- random <- genTLSRandom 48- ePremaster <- decryptRSA encryptedPremaster- case ePremaster of- Left _ -> setMasterSecret random- Right premaster -> case decodePreMasterSecret premaster of- Left _ -> setMasterSecret random- Right (ver, _)- | ver /= expectedVer -> setMasterSecret random- | otherwise -> setMasterSecret premaster+ setMasterSecret =<<+ if expectedVer /= ver+ then genTLSRandom (fromIntegral $ B.length content)+ else return content processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do@@ -123,6 +158,94 @@ throwError $ Error_Protocol("bad record mac", True, BadRecordMac) updateVerifiedData False fdata return ()++-- just `decompress' by returning the data for now till we have compression implemented+uncompressContent :: Record Compressed -> TLSSt (Record Plaintext)+uncompressContent record = onRecordFragment record $ fragmentUncompress $ \bytes ->+ withCompression $ compressionInflate bytes++decryptContent :: Record Ciphertext -> TLSSt (Record Compressed)+decryptContent record = onRecordFragment record $ fragmentUncipher $ \e -> do+ st <- get+ if stRxEncrypted st+ then decryptData e >>= getCipherData record+ else return e++getCipherData :: Record a -> CipherData -> TLSSt ByteString+getCipherData (Record pt ver _) cdata = do+ -- check if the MAC is valid.+ macValid <- case cipherDataMAC cdata of+ Nothing -> return True+ Just digest -> do+ let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)+ expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata+ return (expected_digest `bytesEq` digest)++ -- check if the padding is filled with the correct pattern if it exists+ paddingValid <- case cipherDataPadding cdata of+ Nothing -> return True+ Just pad -> do+ cver <- stVersion <$> get+ let b = B.length pad - 1+ return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad)++ unless (macValid &&! paddingValid) $ do+ throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)++ return $ cipherDataContent cdata++decryptData :: Bytes -> TLSSt CipherData+decryptData econtent = do+ st <- get++ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "rx crypt state" $ stRxCryptState st+ let digestSize = hashSize $ cipherHash cipher+ let writekey = cstKey cst++ case bulkF bulk of+ BulkNoneF -> do+ let contentlen = B.length econtent - digestSize+ case partition3 econtent (contentlen, digestSize, 0) of+ Nothing ->+ throwError $ Error_Misc "partition3 failed"+ Just (content, mac, _) ->+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ }+ BulkBlockF _ decryptF -> do+ {- update IV -}+ let (iv, econtent') =+ if hasExplicitBlockIV $ stVersion st+ then B.splitAt (bulkIVSize bulk) econtent+ else (cstIV cst, econtent)+ let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent'+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }++ 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 "p3" $ partition3 content' (contentlen, digestSize, paddinglength)+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Just padding+ }+ BulkStreamF initF _ decryptF -> do+ let iv = cstIV cst+ let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent+ {- update Ctx -}+ let contentlen = B.length content' - digestSize+ let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)+ put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }+ return $ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ } processCertificates :: [X509] -> TLSSt () processCertificates certs = do
Network/TLS/Record.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE EmptyDataDecls #-} -- | -- Module : Network.TLS.Record -- License : BSD-style@@ -12,21 +13,84 @@ -- higher-level clients. -- module Network.TLS.Record- ( Record(..)+ ( Header(..)+ , ProtocolType(..)+ , packetType+ -- * TLS Records+ , Record(..)+ -- * TLS Record fragment and constructors , Fragment- , fragmentGetBytes , fragmentPlaintext , fragmentCiphertext- , recordToRaw- , rawToRecord- , recordToHeader+ , fragmentGetBytes , Plaintext , Compressed , Ciphertext- , engageRecord- , disengageRecord+ -- * manipulate record+ , onRecordFragment+ , fragmentCompress+ , fragmentCipher+ , fragmentUncipher+ , fragmentUncompress+ -- * serialize record+ , rawToRecord+ , recordToRaw+ , recordToHeader ) where -import Network.TLS.Record.Types-import Network.TLS.Record.Engage-import Network.TLS.Record.Disengage+import Network.TLS.Struct+import Network.TLS.State+import qualified Data.ByteString as B+import Control.Applicative ((<$>))++-- | Represent a TLS record.+data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)++newtype Fragment a = Fragment Bytes deriving (Show,Eq)++data Plaintext+data Compressed+data Ciphertext++fragmentPlaintext :: Bytes -> Fragment Plaintext+fragmentPlaintext bytes = Fragment bytes++fragmentCiphertext :: Bytes -> Fragment Ciphertext+fragmentCiphertext bytes = Fragment bytes++fragmentGetBytes :: Fragment a -> Bytes+fragmentGetBytes (Fragment bytes) = bytes++onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b)+onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag++fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b)+fragmentMap f (Fragment b) = Fragment <$> f b++-- | turn a plaintext record into a compressed record using the compression function supplied+fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed)+fragmentCompress f = fragmentMap f++-- | turn a compressed record into a ciphertext record using the cipher function supplied+fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext)+fragmentCipher f = fragmentMap f++-- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied+fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed)+fragmentUncipher f = fragmentMap f++-- | turn a compressed fragment into a plaintext fragment using the decompression function supplied+fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext)+fragmentUncompress f = fragmentMap f++-- | turn a record into an header and bytes+recordToRaw :: Record a -> (Header, Bytes)+recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes)++-- | turn a header and a fragment into a record+rawToRecord :: Header -> Fragment a -> Record a+rawToRecord (Header pt ver _) fragment = Record pt ver fragment++-- | turn a record into a header+recordToHeader :: Record a -> Header+recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes)
− Network/TLS/Record/Disengage.hs
@@ -1,117 +0,0 @@--- |--- Module : Network.TLS.Record.Disengage--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Disengage a record from the Record layer.--- The record is decrypted, checked for integrity and then decompressed.----module Network.TLS.Record.Disengage- ( disengageRecord- ) where--import Control.Monad.State-import Control.Monad.Error--import Network.TLS.Struct-import Network.TLS.Cap-import Network.TLS.State-import Network.TLS.Record.Types-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Util-import Data.ByteString (ByteString)-import qualified Data.ByteString as B--disengageRecord :: Record Ciphertext -> TLSSt (Record Plaintext)-disengageRecord = decryptRecord >=> uncompressRecord--uncompressRecord :: Record Compressed -> TLSSt (Record Plaintext)-uncompressRecord record = onRecordFragment record $ fragmentUncompress $ \bytes ->- withCompression $ compressionInflate bytes--decryptRecord :: Record Ciphertext -> TLSSt (Record Compressed)-decryptRecord record = onRecordFragment record $ fragmentUncipher $ \e -> do- st <- get- if stRxEncrypted st- then decryptData e >>= getCipherData record- else return e--getCipherData :: Record a -> CipherData -> TLSSt ByteString-getCipherData (Record pt ver _) cdata = do- -- check if the MAC is valid.- macValid <- case cipherDataMAC cdata of- Nothing -> return True- Just digest -> do- let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)- expected_digest <- makeDigest False new_hdr $ cipherDataContent cdata- return (expected_digest `bytesEq` digest)-- -- check if the padding is filled with the correct pattern if it exists- paddingValid <- case cipherDataPadding cdata of- Nothing -> return True- Just pad -> do- cver <- gets stVersion- let b = B.length pad - 1- return (if cver < TLS10 then True else B.replicate (B.length pad) (fromIntegral b) `bytesEq` pad)-- unless (macValid &&! paddingValid) $ do- throwError $ Error_Protocol ("bad record mac", True, BadRecordMac)-- return $ cipherDataContent cdata--decryptData :: Bytes -> TLSSt CipherData-decryptData econtent = do- st <- get-- let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "rx crypt state" $ stRxCryptState st- let digestSize = hashSize $ cipherHash cipher- let writekey = cstKey cst-- case bulkF bulk of- BulkNoneF -> do- let contentlen = B.length econtent - digestSize- case partition3 econtent (contentlen, digestSize, 0) of- Nothing ->- throwError $ Error_Misc "partition3 failed"- Just (content, mac, _) ->- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }- BulkBlockF _ decryptF -> do- {- update IV -}- let (iv, econtent') =- if hasExplicitBlockIV $ stVersion st- then B.splitAt (bulkIVSize bulk) econtent- else (cstIV cst, econtent)- let newiv = fromJust "new iv" $ takelast (bulkBlockSize bulk) econtent'- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }-- 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 "p3" $ partition3 content' (contentlen, digestSize, paddinglength)- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just padding- }- BulkStreamF initF _ decryptF -> do- let iv = cstIV cst- let (content', newiv) = decryptF (if iv /= B.empty then iv else initF writekey) econtent- {- update Ctx -}- let contentlen = B.length content' - digestSize- let (content, mac, _) = fromJust "p3" $ partition3 content' (contentlen, digestSize, 0)- put $ st { stRxCryptState = Just $ cst { cstIV = newiv } }- return $ CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Nothing- }-
− Network/TLS/Record/Engage.hs
@@ -1,89 +0,0 @@--- |--- Module : Network.TLS.Record.Engage--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ Engage a record into the Record layer.--- The record is compressed, added some integrity field, then encrypted.----module Network.TLS.Record.Engage- ( engageRecord- ) where--import Control.Monad.State--import Network.TLS.Cap-import Network.TLS.State-import Network.TLS.Record.Types-import Network.TLS.Cipher-import Network.TLS.Compression-import Network.TLS.Util-import Data.ByteString (ByteString)-import qualified Data.ByteString as B--engageRecord :: Record Plaintext -> TLSSt (Record Ciphertext)-engageRecord = compressRecord >=> encryptRecord--compressRecord :: Record Plaintext -> TLSSt (Record Compressed)-compressRecord record =- onRecordFragment record $ fragmentCompress $ \bytes -> do- withCompression $ compressionDeflate bytes--{-- - when Tx Encrypted is set, we pass the data through encryptContent, otherwise- - we just return the packet- -}-encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext)-encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do- st <- get- if stTxEncrypted st- then encryptContent record bytes- else return bytes--encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString-encryptContent record content = do- digest <- makeDigest True (recordToHeader record) content- encryptData $ B.concat [content, digest]--encryptData :: ByteString -> TLSSt ByteString-encryptData content = do- st <- get-- let cipher = fromJust "cipher" $ stCipher st- let bulk = cipherBulk cipher- let cst = fromJust "tx crypt state" $ stTxCryptState st-- let writekey = cstKey cst-- case bulkF bulk of- BulkNoneF -> return content- BulkBlockF encrypt _ -> do- let blockSize = fromIntegral $ bulkBlockSize bulk- let msg_len = B.length content- let padding = if blockSize > 0- then- let padbyte = blockSize - (msg_len `mod` blockSize) in- let padbyte' = if padbyte == 0 then blockSize else padbyte in- B.replicate padbyte' (fromIntegral (padbyte' - 1))- else- B.empty-- -- before TLS 1.1, the block cipher IV is made of the residual of the previous block.- iv <- if hasExplicitBlockIV $ stVersion st- then genTLSRandom (bulkIVSize bulk)- else return $ cstIV cst- let e = encrypt writekey iv (B.concat [ content, padding ])- if hasExplicitBlockIV $ stVersion st- then return $ B.concat [iv,e]- else do- let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e- put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }- return e- BulkStreamF initF encryptF _ -> do- let iv = cstIV cst- let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content- put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }- return e-
− Network/TLS/Record/Types.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}--- |--- Module : Network.TLS.Record.Types--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ The Record Protocol takes messages to be transmitted, fragments the--- data into manageable blocks, optionally compresses the data, applies--- a MAC, encrypts, and transmits the result. Received data is--- decrypted, verified, decompressed, reassembled, and then delivered to--- higher-level clients.----module Network.TLS.Record.Types- ( Header(..)- , ProtocolType(..)- , packetType- -- * TLS Records- , Record(..)- -- * TLS Record fragment and constructors- , Fragment- , fragmentPlaintext- , fragmentCiphertext- , fragmentGetBytes- , Plaintext- , Compressed- , Ciphertext- -- * manipulate record- , onRecordFragment- , fragmentCompress- , fragmentCipher- , fragmentUncipher- , fragmentUncompress- -- * serialize record- , rawToRecord- , recordToRaw- , recordToHeader- ) where--import Network.TLS.Struct-import Network.TLS.State-import qualified Data.ByteString as B-import Control.Applicative ((<$>))---- | Represent a TLS record.-data Record a = Record !ProtocolType !Version !(Fragment a) deriving (Show,Eq)--newtype Fragment a = Fragment Bytes deriving (Show,Eq)--data Plaintext-data Compressed-data Ciphertext--fragmentPlaintext :: Bytes -> Fragment Plaintext-fragmentPlaintext bytes = Fragment bytes--fragmentCiphertext :: Bytes -> Fragment Ciphertext-fragmentCiphertext bytes = Fragment bytes--fragmentGetBytes :: Fragment a -> Bytes-fragmentGetBytes (Fragment bytes) = bytes--onRecordFragment :: Record a -> (Fragment a -> TLSSt (Fragment b)) -> TLSSt (Record b)-onRecordFragment (Record pt ver frag) f = Record pt ver <$> f frag--fragmentMap :: (Bytes -> TLSSt Bytes) -> Fragment a -> TLSSt (Fragment b)-fragmentMap f (Fragment b) = Fragment <$> f b---- | turn a plaintext record into a compressed record using the compression function supplied-fragmentCompress :: (Bytes -> TLSSt Bytes) -> Fragment Plaintext -> TLSSt (Fragment Compressed)-fragmentCompress f = fragmentMap f---- | turn a compressed record into a ciphertext record using the cipher function supplied-fragmentCipher :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Ciphertext)-fragmentCipher f = fragmentMap f---- | turn a ciphertext fragment into a compressed fragment using the cipher function supplied-fragmentUncipher :: (Bytes -> TLSSt Bytes) -> Fragment Ciphertext -> TLSSt (Fragment Compressed)-fragmentUncipher f = fragmentMap f---- | turn a compressed fragment into a plaintext fragment using the decompression function supplied-fragmentUncompress :: (Bytes -> TLSSt Bytes) -> Fragment Compressed -> TLSSt (Fragment Plaintext)-fragmentUncompress f = fragmentMap f---- | turn a record into an header and bytes-recordToRaw :: Record a -> (Header, Bytes)-recordToRaw (Record pt ver (Fragment bytes)) = (Header pt ver (fromIntegral $ B.length bytes), bytes)---- | turn a header and a fragment into a record-rawToRecord :: Header -> Fragment a -> Record a-rawToRecord (Header pt ver _) fragment = Record pt ver fragment---- | turn a record into a header-recordToHeader :: Record a -> Header-recordToHeader (Record pt ver (Fragment bytes)) = Header pt ver (fromIntegral $ B.length bytes)
Network/TLS/Sending.hs view
@@ -8,7 +8,9 @@ -- the Sending module contains calls related to marshalling packets according -- to the TLS state ---module Network.TLS.Sending (writePacket, encryptRSA) where+module Network.TLS.Sending (+ writePacket+ ) where import Control.Applicative ((<$>)) import Control.Monad.State@@ -17,10 +19,14 @@ import qualified Data.ByteString as B import Network.TLS.Util+import Network.TLS.Cap+import Network.TLS.Wire import Network.TLS.Struct import Network.TLS.Record import Network.TLS.Packet import Network.TLS.State+import Network.TLS.Cipher+import Network.TLS.Compression import Network.TLS.Crypto {-@@ -41,7 +47,23 @@ when (ty == ProtocolType_Handshake) (updateHandshakeDigest $ fragmentGetBytes fragment) return record +compressRecord :: Record Plaintext -> TLSSt (Record Compressed)+compressRecord record =+ onRecordFragment record $ fragmentCompress $ \bytes -> do+ withCompression $ compressionDeflate bytes+ {-+ - when Tx Encrypted is set, we pass the data through encryptContent, otherwise+ - we just return the packet+ -}+encryptRecord :: Record Compressed -> TLSSt (Record Ciphertext)+encryptRecord record = onRecordFragment record $ fragmentCipher $ \bytes -> do+ st <- get+ if stTxEncrypted st+ then encryptContent record bytes+ else return bytes++{- - ChangeCipherSpec state change need to be handled after encryption otherwise - its own packet would be encrypted with the new context, instead of beeing sent - under the current context@@ -64,8 +86,10 @@ preProcessPacket :: Packet -> TLSSt () preProcessPacket (Alert _) = return () preProcessPacket (AppData _) = return ()-preProcessPacket (ChangeCipherSpec) = return ()+preProcessPacket (ChangeCipherSpec) = updateStatusCC True >> return () -- FIXME don't ignore this error just in case preProcessPacket (Handshake hss) = forM_ hss $ \hs -> do+ -- FIXME don't ignore this error+ _ <- updateStatusHs (typeOfHandshake hs) case hs of Finished fdata -> updateVerifiedData True fdata _ -> return ()@@ -77,7 +101,7 @@ writePacket :: Packet -> TLSSt ByteString writePacket pkt = do preProcessPacket pkt- makeRecord pkt >>= processRecord >>= engageRecord >>= postprocessRecord >>= encodeRecord+ makeRecord pkt >>= processRecord >>= compressRecord >>= encryptRecord >>= postprocessRecord >>= encodeRecord {------------------------------------------------------------------------------} {- SENDING Helpers -}@@ -94,8 +118,68 @@ Left err -> fail ("rsa encrypt failed: " ++ show err) Right (econtent, rng') -> put (st { stRandomGen = rng' }) >> return econtent +encryptContent :: Record Compressed -> ByteString -> TLSSt ByteString+encryptContent record content = do+ digest <- makeDigest True (recordToHeader record) content+ encryptData $ B.concat [content, digest]++encryptData :: ByteString -> TLSSt ByteString+encryptData content = do+ st <- get++ let cipher = fromJust "cipher" $ stCipher st+ let bulk = cipherBulk cipher+ let cst = fromJust "tx crypt state" $ stTxCryptState st++ let writekey = cstKey cst++ case bulkF bulk of+ BulkNoneF -> return content+ BulkBlockF encrypt _ -> do+ let blockSize = fromIntegral $ bulkBlockSize bulk+ let msg_len = B.length content+ let padding = if blockSize > 0+ then+ let padbyte = blockSize - (msg_len `mod` blockSize) in+ let padbyte' = if padbyte == 0 then blockSize else padbyte in+ B.replicate padbyte' (fromIntegral (padbyte' - 1))+ else+ B.empty++ -- before TLS 1.1, the block cipher IV is made of the residual of the previous block.+ iv <- if hasExplicitBlockIV $ stVersion st+ then genTLSRandom (bulkIVSize bulk)+ else return $ cstIV cst+ let e = encrypt writekey iv (B.concat [ content, padding ])+ if hasExplicitBlockIV $ stVersion st+ then return $ B.concat [iv,e]+ else do+ let newiv = fromJust "new iv" $ takelast (bulkIVSize bulk) e+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return e+ BulkStreamF initF encryptF _ -> do+ let iv = cstIV cst+ let (e, newiv) = encryptF (if iv /= B.empty then iv else initF writekey) content+ put $ st { stTxCryptState = Just $ cst { cstIV = newiv } }+ return e+ writePacketContent :: Packet -> TLSSt ByteString-writePacketContent (Handshake hss) = return $ encodeHandshakes hss+writePacketContent (Handshake hss) = return . B.concat =<< mapM makeContent hss where+ makeContent hs@(ClientKeyXchg _ _) = do+ ver <- get >>= return . stVersion+ let premastersecret = runPut $ encodeHandshakeContent hs+ setMasterSecret premastersecret+ econtent <- encryptRSA premastersecret++ let extralength =+ if ver < TLS10+ then B.empty+ else runPut $ putWord16 $ fromIntegral $ B.length econtent+ let hdr = runPut $ encodeHandshakeHeader (typeOfHandshake hs)+ (fromIntegral (B.length econtent + B.length extralength))+ return $ B.concat [hdr, extralength, econtent]+ makeContent hs = return $ encodeHandshakes [hs]+ writePacketContent (Alert a) = return $ encodeAlerts a writePacketContent (ChangeCipherSpec) = return $ encodeChangeCipherSpec writePacketContent (AppData x) = return x
Network/TLS/State.hs view
@@ -16,11 +16,15 @@ , TLSHandshakeState(..) , TLSCryptState(..) , TLSMacState(..)+ , TLSStatus(..)+ , HandshakeStatus(..) , newTLSState , genTLSRandom , withTLSRNG , withCompression , assert -- FIXME move somewhere else (Internal.hs ?)+ , updateStatusHs+ , updateStatusCC , updateVerifiedData , finishHandshakeTypeMaterial , finishHandshakeMaterial@@ -41,11 +45,13 @@ , isClientContext , startHandshakeClient , updateHandshakeDigest+ , updateHandshakeDigestSplitted , getHandshakeDigest , endHandshake ) where import Data.Word+import Data.List (find) import Data.Maybe (isNothing) import Network.TLS.Util import Network.TLS.Struct@@ -66,6 +72,28 @@ assert fctname list = forM_ list $ \ (name, assumption) -> do when assumption $ fail (fctname ++ ": assumption about " ++ name ++ " failed") +data HandshakeStatus =+ HsStatusClientHello+ | HsStatusServerHello+ | HsStatusServerCertificate+ | HsStatusServerKeyXchg+ | HsStatusServerCertificateReq+ | HsStatusServerHelloDone+ | HsStatusClientCertificate+ | HsStatusClientKeyXchg+ | HsStatusClientCertificateVerify+ | HsStatusClientChangeCipher+ | HsStatusClientFinished+ | HsStatusServerChangeCipher+ deriving (Show,Eq)++data TLSStatus =+ StatusInit+ | StatusHandshakeReq+ | StatusHandshake HandshakeStatus+ | StatusOk+ deriving (Show,Eq)+ data TLSCryptState = TLSCryptState { cstKey :: !Bytes , cstIV :: !Bytes@@ -94,6 +122,7 @@ data TLSState = TLSState { stClientContext :: Bool , stVersion :: !Version+ , stStatus :: !TLSStatus , stHandshake :: !(Maybe TLSHandshakeState) , stTxEncrypted :: Bool , stRxEncrypted :: Bool@@ -126,6 +155,7 @@ newTLSState rng = TLSState { stClientContext = False , stVersion = TLS10+ , stStatus = StatusInit , stHandshake = Nothing , stTxEncrypted = False , stRxEncrypted = False@@ -180,6 +210,68 @@ modify (\_ -> 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 :: MonadState TLSState m => TLSStatus -> m ()+updateStatus x = modify (\st -> st { stStatus = x })++updateStatusHs :: MonadState TLSState m => HandshakeType -> m (Maybe TLSError)+updateStatusHs ty = do+ status <- return . stStatus =<< get+ ns <- return . transition . stStatus =<< get+ 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 :: MonadState TLSState m => Bool -> m (Maybe TLSError)+updateStatusCC sending = do+ status <- return . stStatus =<< get+ 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)+ updateVerifiedData :: MonadState TLSState m => Bool -> Bytes -> m () updateVerifiedData sending bs = do cc <- isClientContext@@ -315,6 +407,11 @@ updateHandshakeDigest :: MonadState TLSState m => Bytes -> m () updateHandshakeDigest content = updateHandshake "update digest" $ \hs -> hs { hstHandshakeDigest = hashUpdate (hstHandshakeDigest hs) content }++updateHandshakeDigestSplitted :: MonadState TLSState m => HandshakeType -> Bytes -> m ()+updateHandshakeDigestSplitted ty bytes = updateHandshakeDigest $ B.concat [hdr, bytes]+ where+ hdr = runPut $ encodeHandshakeHeader ty (B.length bytes) getHandshakeDigest :: MonadState TLSState m => Bool -> m Bytes getHandshakeDigest client = do
Network/TLS/Struct.hs view
@@ -28,6 +28,7 @@ , Header(..) , ServerRandom(..) , ClientRandom(..)+ , ClientKeyData(..) , serverRandom , clientRandom , FinishedData@@ -111,7 +112,6 @@ Error_Misc String -- ^ mainly for instance of Error | Error_Protocol (String, Bool, AlertDescription) | Error_Certificate String- | Error_HandshakePolicy String -- ^ handshake policy failed. | Error_Random String | Error_EOF | Error_Packet String@@ -140,6 +140,7 @@ newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)+newtype ClientKeyData = ClientKeyData Bytes deriving (Show, Eq) newtype Session = Session (Maybe Bytes) deriving (Show, Eq) type CipherID = Word16 type CompressionID = Word8@@ -226,7 +227,7 @@ | Certificates [X509] | HelloRequest | ServerHelloDone- | ClientKeyXchg Bytes+ | ClientKeyXchg Version ClientKeyData | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] (Maybe [ (HashAlgorithm, SignatureAlgorithm) ]) [Word8] | CertVerify [Word8]@@ -245,7 +246,7 @@ typeOfHandshake (Certificates _) = HandshakeType_Certificate typeOfHandshake (HelloRequest) = HandshakeType_HelloRequest typeOfHandshake (ServerHelloDone) = HandshakeType_ServerHelloDone-typeOfHandshake (ClientKeyXchg _) = HandshakeType_ClientKeyXchg+typeOfHandshake (ClientKeyXchg _ _) = HandshakeType_ClientKeyXchg typeOfHandshake (ServerKeyXchg _) = HandshakeType_ServerKeyXchg typeOfHandshake (CertRequest _ _ _) = HandshakeType_CertRequest typeOfHandshake (CertVerify _) = HandshakeType_CertVerify
Tests.hs view
@@ -1,28 +1,22 @@ {-# LANGUAGE CPP #-} import Test.QuickCheck-import Test.QuickCheck.Monadic+import Test.QuickCheck.Test import Test.Framework (defaultMain, testGroup) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Tests.Certificate-import Tests.PipeChan-import Tests.Connection+--import Tests.Certificate import Data.Word+import Data.Certificate.X509 import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Network.TLS.Core import Network.TLS.Cipher import Network.TLS.Struct import Network.TLS.Packet-import Control.Applicative-import Control.Concurrent-import Control.Exception (throw, catch, SomeException) import Control.Monad--import Prelude hiding (catch)+import Control.Applicative+import System.IO genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i@@ -55,12 +49,15 @@ instance Arbitrary ServerRandom where arbitrary = ServerRandom <$> (genByteString 32) +instance Arbitrary ClientKeyData where+ arbitrary = ClientKeyData <$> (genByteString 46)+ instance Arbitrary Session where arbitrary = do i <- choose (1,2) :: Gen Int case i of+ 1 -> return $ Session Nothing 2 -> liftM (Session . Just) (genByteString 32)- _ -> return $ Session Nothing arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0,200) >>= vector@@ -91,10 +88,10 @@ <*> arbitrary <*> arbitrary <*> (return [])- , liftM Certificates (resize 2 $ listOf $ arbitraryX509)+ --, liftM Certificates (resize 2 $ listOf $ arbitraryX509 pubkey) , pure HelloRequest , pure ServerHelloDone- , ClientKeyXchg <$> genByteString 48+ , ClientKeyXchg <$> arbitrary <*> arbitrary --, liftM ServerKeyXchg --, liftM3 CertRequest arbitrary (return Nothing) (return []) --, liftM CertVerify (return [])@@ -103,95 +100,15 @@ {- quickcheck property -} -prop_header_marshalling_id :: Header -> Bool prop_header_marshalling_id x = (decodeHeader $ encodeHeader x) == Right x--prop_handshake_marshalling_id :: Handshake -> Bool prop_handshake_marshalling_id x = (decodeHs $ encodeHandshake x) == Right x where decodeHs b = either (Left . id) (uncurry (decodeHandshake cp) . head) $ decodeHandshakes b cp = CurrentParams { cParamsVersion = TLS10, cParamsKeyXchgType = CipherKeyExchange_RSA } -prop_pipe_work :: PropertyM IO ()-prop_pipe_work = do- pipe <- run newPipe- _ <- run (runPipe pipe)-- let bSize = 16- n <- pick (choose (1, 32))-- let d1 = B.replicate (bSize * n) 40- let d2 = B.replicate (bSize * n) 45-- d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1))- d1 `assertEq` d1'-- d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2))- d2 `assertEq` d2'-- return ()--prop_handshake_initiate :: PropertyM IO ()-prop_handshake_initiate = do- -- initial setup- pipe <- run newPipe- _ <- run (runPipe pipe)- startQueue <- run newChan- resultQueue <- run newChan-- params <- pick arbitraryPairParams- (cCtx, sCtx) <- run $ newPairContext pipe params-- _ <- run $ forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")- _ <- run $ forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client")-- {- the test involves writing data on one side of the data "pipe" and- - then checking we received them on the other side of the data "pipe" -}- d <- L.pack <$> pick (someWords8 256)- run $ writeChan startQueue d-- dres <- run $ readChan resultQueue- d `assertEq` dres-- return ()- where- printAndRaise :: String -> SomeException -> IO ()- printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e-- someWords8 :: Int -> Gen [Word8]- someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))-- tlsServer ctx queue = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on server side"- d <- recvData ctx- writeChan queue d- return ()- tlsClient queue ctx = do- hSuccess <- handshake ctx- unless hSuccess $ fail "handshake failed on client side"- d <- readChan queue- sendData ctx d- bye ctx- return ()--assertEq :: (Show a, Monad m, Eq a) => a -> a -> m ()-assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected)--main :: IO ()-main = defaultMain- [ tests_marshalling- , tests_handshake+tests = testGroup "Marshalling"+ [ testProperty "Header" prop_header_marshalling_id+ , testProperty "Handshake" prop_handshake_marshalling_id ]- where- -- lowlevel tests to check the packet marshalling.- tests_marshalling = testGroup "Marshalling"- [ testProperty "Header" prop_header_marshalling_id- , testProperty "Handshake" prop_handshake_marshalling_id- ] - -- high level tests between a client and server with fake ciphers.- tests_handshake = testGroup "Handshakes"- [ testProperty "setup" (monadicIO prop_pipe_work)- , testProperty "initiate" (monadicIO prop_handshake_initiate)- ]+main = defaultMain [ tests ]
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.8.3+Version: 0.8.3.1 Description: Native Haskell TLS and SSL protocol implementation for server and client. .@@ -49,15 +49,11 @@ Network.TLS.Internal other-modules: Network.TLS.Cap Network.TLS.Struct+ Network.TLS.MAC Network.TLS.Core Network.TLS.Crypto- Network.TLS.MAC- Network.TLS.Measurement Network.TLS.Packet Network.TLS.Record- Network.TLS.Record.Types- Network.TLS.Record.Engage- Network.TLS.Record.Disengage Network.TLS.State Network.TLS.Sending Network.TLS.Receiving@@ -74,9 +70,6 @@ , test-framework , test-framework-quickcheck2 , bytestring- , time- , cprng-aes- , cryptocipher >= 0.3.0 else Buildable: False ghc-options: -Wall -fhpc