tls 0.8.3.2 → 0.8.4
raw patch · 8 files changed
+283/−84 lines, 8 files
Files
- Network/TLS/Context.hs +11/−0
- Network/TLS/Core.hs +91/−41
- Network/TLS/Receiving.hs +21/−19
- Network/TLS/Sending.hs +1/−1
- Network/TLS/State.hs +45/−5
- Network/TLS/Struct.hs +11/−3
- Tests.hs +102/−14
- tls.cabal +1/−1
Network/TLS/Context.hs view
@@ -10,6 +10,7 @@ -- * Context configuration TLSParams(..) , TLSLogging(..)+ , SessionData(..) , Measurement(..) , TLSCertificateUsage(..) , TLSCertificateRejectReason(..)@@ -73,10 +74,15 @@ , pWantClientCert :: Bool -- ^ request a certificate from client. -- use by server only. , pUseSecureRenegotiation :: Bool -- notify that we want to use secure renegotation+ , pUseSession :: Bool -- generate new session if specified , 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.+ , onSessionResumption :: SessionID -> IO (Maybe SessionData) -- ^ callback to maybe resume session on server.+ , onSessionEstablished :: SessionID -> SessionData -> IO () -- ^ callback when session have been established+ , onSessionInvalidated :: SessionID -> IO () -- ^ callback when session is invalidated by error+ , sessionResumeWith :: Maybe (SessionID, SessionData) -- ^ try to establish a connection using this session. } defaultLogging :: TLSLogging@@ -95,10 +101,15 @@ , pCompressions = [nullCompression] , pWantClientCert = False , pUseSecureRenegotiation = True+ , pUseSession = True , pCertificates = [] , pLogging = defaultLogging , onHandshake = (\_ -> return True) , onCertificatesRecv = (\_ -> return CertificateUsageAccept)+ , onSessionResumption = (\_ -> return Nothing)+ , onSessionEstablished = (\_ _ -> return ())+ , onSessionInvalidated = (\_ -> return ())+ , sessionResumeWith = Nothing } instance Show TLSParams where
Network/TLS/Core.hs view
@@ -124,9 +124,22 @@ sendPacket ctx (Handshake [Finished cf]) liftIO $ connectionFlush ctx +recvChangeCipherAndFinish :: MonadIO m => TLSCtx c -> m ()+recvChangeCipherAndFinish ctx = 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")+ unexpected :: MonadIO m => String -> Maybe [Char] -> m a unexpected msg expected = throwCore $ Error_Packet_unexpected msg (maybe "" (" expected: " ++) expected) +newSession :: MonadIO m => TLSCtx c -> m Session+newSession ctx+ | pUseSession $ ctxParams ctx = getStateRNG ctx 32 >>= return . Session . Just+ | otherwise = return $ Session Nothing+ -- | Send one packet to the context sendPacket :: MonadIO m => TLSCtx c -> Packet -> m () sendPacket ctx pkt = do@@ -167,6 +180,21 @@ bye :: MonadIO m => TLSCtx c -> m () bye ctx = sendPacket ctx $ Alert [(AlertLevel_Warning, CloseNotify)] +-- | when a new handshake is done, wrap up & clean up.+handshakeTerminate :: MonadIO m => TLSCtx c -> m ()+handshakeTerminate ctx = do+ session <- usingState_ ctx getSession+ -- only callback the session established if we have a session+ case session of+ Session (Just sessionId) -> do+ sessionData <- usingState_ ctx getSessionData+ liftIO $ (onSessionEstablished $ ctxParams ctx) sessionId (fromJust sessionData)+ _ -> return ()+ -- forget all handshake data now and reset bytes counters.+ usingState_ ctx endHandshake+ updateMeasure ctx resetBytesCounters+ return ()+ -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: MonadIO m => TLSCtx c -> m ()@@ -174,11 +202,14 @@ updateMeasure ctx incrementNbHandshakes sendClientHello recvServerHello- sendCertificate >> sendClientKeyXchg >> sendCertificateVerify- sendChangeCipherAndFinish ctx True- recvChangeCipherAndFinish- updateMeasure ctx resetBytesCounters-+ sessionResuming <- usingState_ ctx isSessionResuming+ if sessionResuming+ then sendChangeCipherAndFinish ctx True+ else do+ sendCertificate >> sendClientKeyXchg >> sendCertificateVerify+ sendChangeCipherAndFinish ctx True+ recvChangeCipherAndFinish ctx+ handshakeTerminate ctx where params = ctxParams ctx ver = pConnectVersion params@@ -193,19 +224,18 @@ sendClientHello = do crand <- getStateRNG ctx 32 >>= return . ClientRandom+ let clientSession = Session . maybe Nothing (Just . fst) $ sessionResumeWith params extensions <- getExtensions usingState_ ctx (startHandshakeClient ver crand) sendPacket ctx $ Handshake- [ ClientHello ver crand (Session Nothing) (map cipherID ciphers)+ [ ClientHello ver crand clientSession (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")+ 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.@@ -217,10 +247,10 @@ {- FIXME not implemented yet -} return () - recvServerHello = runRecvState ctx (RecvStateHandshake processServerHello)+ recvServerHello = runRecvState ctx (RecvStateHandshake onServerHello) - processServerHello :: MonadIO m => Handshake -> m (RecvState m)- processServerHello (ServerHello rver _ _ cipher _ _) = do+ onServerHello :: MonadIO m => Handshake -> m (RecvState m)+ onServerHello sh@(ServerHello rver _ serverSession 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)@@ -228,9 +258,19 @@ 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") + let resumingSession = case sessionResumeWith params of+ Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing+ Nothing -> Nothing+ usingState_ ctx $ setSession serverSession (isJust resumingSession)+ usingState_ ctx $ processServerHello sh+ case resumingSession of+ Nothing -> return $ RecvStateHandshake processCertificate+ Just sessionData -> do+ usingState_ ctx (setMasterSecret $ sessionSecret sessionData)+ return $ RecvStateNext expectChangeCipher+ onServerHello p = unexpected (show p) (Just "server hello")+ processCertificate :: MonadIO m => Handshake -> m (RecvState m) processCertificate (Certificates certs) = do let cb = onCertificatesRecv $ params@@ -258,7 +298,7 @@ xver <- stVersion <$> get prerand <- genTLSRandom 46 let premaster = encodePreMasterSecret xver prerand- setMasterSecret premaster+ setMasterSecretFromPre premaster -- SSL3 implementation generally forget this length field since it's redundant, -- however TLS10 make it clear that the length field need to be present.@@ -280,7 +320,7 @@ throwCore $ Error_Protocol ("certificate rejected: " ++ s, True, CertificateUnknown) handshakeServerWith :: MonadIO m => TLSCtx c -> Handshake -> m ()-handshakeServerWith ctx clientHello@(ClientHello ver _ _ ciphers compressions _) = do+handshakeServerWith ctx clientHello@(ClientHello ver _ clientSession 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")@@ -301,16 +341,25 @@ , stCompression = usedCompression }) - -- send Server Data until ServerHelloDone- handshakeSendServerData- liftIO $ connectionFlush ctx-- -- Receive client info until client Finished.- recvClientData- sendChangeCipherAndFinish ctx False+ resumeSessionData <- case clientSession of+ (Session (Just clientSessionId)) -> liftIO $ onSessionResumption params $ clientSessionId+ (Session Nothing) -> return Nothing+ case resumeSessionData of+ Nothing -> do+ handshakeSendServerData+ liftIO $ connectionFlush ctx - updateMeasure ctx resetBytesCounters- return ()+ -- Receive client info until client Finished.+ recvClientData+ sendChangeCipherAndFinish ctx False+ Just sessionData -> do+ usingState_ ctx (setSession clientSession True)+ serverhello <- makeServerHello clientSession+ sendPacket ctx $ Handshake [serverhello]+ usingState_ ctx $ setMasterSecret $ sessionSecret sessionData+ sendChangeCipherAndFinish ctx False+ recvChangeCipherAndFinish ctx+ handshakeTerminate ctx where params = ctxParams ctx commonCiphers = intersect ciphers (map cipherID $ pCiphers params)@@ -340,17 +389,14 @@ expectFinish p = unexpected (show p) (Just "Handshake Finished") --- - handshakeSendServerData = do+ makeServerHello session = do srand <- getStateRNG ctx 32 >>= return . ServerRandom- case privKeys of (Just privkey : _) -> usingState_ ctx $ setPrivateKey privkey _ -> return () -- return a sensible error -- in TLS12, we need to check as well the certificates we are sending if they have in the extension -- the necessary bits set.-- -- send ServerHello & Certificate & ServerKeyXchg & CertReq secReneg <- usingState_ ctx getSecureRenegotiation extensions <- if secReneg then do@@ -361,11 +407,15 @@ return [ (0xff01, vf) ] else return [] usingState_ ctx (setVersion ver >> setServerRandom srand)- sendPacket ctx $ Handshake- [ ServerHello ver srand (Session Nothing) (cipherID usedCipher)- (compressionID usedCompression) extensions- , Certificates srvCerts- ]+ return $ ServerHello ver srand session (cipherID usedCipher)+ (compressionID usedCompression) extensions++ handshakeSendServerData = do+ serverSession <- newSession ctx+ usingState_ ctx (setSession serverSession False)+ serverhello <- makeServerHello serverSession+ -- send ServerHello & Certificate & ServerKeyXchg & CertReq+ sendPacket ctx $ Handshake [ serverhello, Certificates srvCerts ] when needKeyXchg $ do let skg = SKX_RSA Nothing sendPacket ctx (Handshake [ServerKeyXchg skg])@@ -382,10 +432,10 @@ -- after receiving a client hello, we need to redo a handshake handshakeServer :: MonadIO m => TLSCtx c -> m () handshakeServer ctx = do- pkts <- recvPacket ctx- case pkts of- Right (Handshake [hs]) -> handshakeServerWith ctx hs- x -> fail ("unexpected type received. expecting handshake ++ " ++ show x)+ hss <- recvPacketHandshake ctx+ case hss of+ [ch] -> handshakeServerWith ctx ch+ _ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss) -- | Handshake for a new TLS connection -- This is to be called at the beginning of a connection, and during renegociation
Network/TLS/Receiving.hs view
@@ -8,7 +8,7 @@ -- 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 (processHandshake, processPacket, processServerHello) where import Control.Applicative ((<$>)) import Control.Monad.State@@ -39,7 +39,6 @@ processPacket (Record ProtocolType_ChangeCipherSpec _ fragment) = do returnEither $ decodeChangeCipherSpec $ fragmentGetBytes fragment switchRxEncryption- isClientContext >>= \cc -> when (not cc) setKeyBlock return ChangeCipherSpec processPacket (Record ProtocolType_Handshake ver fragment) = do@@ -62,13 +61,6 @@ ClientHello cver ran _ _ _ ex -> unless clientmode $ do mapM_ processClientExtension ex startHandshakeClient cver ran- ServerHello sver ran _ _ _ ex -> when clientmode $ do- -- FIXME notify the user to take action if the extension requested is missing- -- secreneg <- getSecureRenegotiation- -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ...- mapM_ processServerExtension ex- setServerRandom ran- setVersion sver Certificates certs -> when clientmode $ do processCertificates certs ClientKeyXchg content -> unless clientmode $ do processClientKeyXchg content@@ -86,6 +78,21 @@ -- unknown extensions processClientExtension _ = return () +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 (if ver < TLS10 then econtent else B.drop 2 econtent)++processServerHello :: Handshake -> TLSSt ()+processServerHello (ServerHello sver ran _ _ _ ex) = do+ -- FIXME notify the user to take action if the extension requested is missing+ -- secreneg <- getSecureRenegotiation+ -- when (secreneg && (isNothing $ lookup 0xff01 ex)) $ ...+ mapM_ processServerExtension ex+ setServerRandom ran+ setVersion sver+ where processServerExtension (0xff01, content) = do cv <- getVerifiedData True sv <- getVerifiedData False@@ -94,12 +101,7 @@ return () processServerExtension _ = return ()--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 (if ver < TLS10 then econtent else B.drop 2 econtent)+processServerHello _ = error "processServerHello called on wrong type" -- process the client key exchange message. the protocol expects the initial -- client version received in ClientHello, not the negociated version.@@ -110,12 +112,12 @@ random <- genTLSRandom 48 ePremaster <- decryptRSA encryptedPremaster case ePremaster of- Left _ -> setMasterSecret random+ Left _ -> setMasterSecretFromPre random Right premaster -> case decodePreMasterSecret premaster of- Left _ -> setMasterSecret random+ Left _ -> setMasterSecretFromPre random Right (ver, _)- | ver /= expectedVer -> setMasterSecret random- | otherwise -> setMasterSecret premaster+ | ver /= expectedVer -> setMasterSecretFromPre random+ | otherwise -> setMasterSecretFromPre premaster processClientFinished :: FinishedData -> TLSSt () processClientFinished fdata = do
Network/TLS/Sending.hs view
@@ -48,7 +48,7 @@ -} postprocessRecord :: Record Ciphertext -> TLSSt (Record Ciphertext) postprocessRecord record@(Record ProtocolType_ChangeCipherSpec _ _) =- switchTxEncryption >> isClientContext >>= \cc -> when cc setKeyBlock >> return record+ switchTxEncryption >> return record postprocessRecord record = return record {-
Network/TLS/State.hs view
@@ -26,6 +26,7 @@ , finishHandshakeMaterial , makeDigest , setMasterSecret+ , setMasterSecretFromPre , setPublicKey , setPrivateKey , setKeyBlock@@ -35,6 +36,10 @@ , setSecureRenegotiation , getSecureRenegotiation , getVerifiedData+ , setSession+ , getSession+ , getSessionData+ , isSessionResuming , switchTxEncryption , switchRxEncryption , getCipherKeyExchangeType@@ -95,6 +100,8 @@ { stClientContext :: Bool , stVersion :: !Version , stHandshake :: !(Maybe TLSHandshakeState)+ , stSession :: Session+ , stSessionResuming :: Bool , stTxEncrypted :: Bool , stRxEncrypted :: Bool , stTxCryptState :: !(Maybe TLSCryptState)@@ -127,6 +134,8 @@ { stClientContext = False , stVersion = TLS10 , stHandshake = Nothing+ , stSession = Session Nothing+ , stSessionResuming = False , stTxEncrypted = False , stRxEncrypted = False , stTxCryptState = Nothing@@ -210,20 +219,51 @@ setServerRandom ran = updateHandshake "srand" (\hst -> hst { hstServerRandom = Just ran }) setMasterSecret :: MonadState TLSState m => Bytes -> m ()-setMasterSecret premastersecret = do- st <- get+setMasterSecret masterSecret = do hasValidHandshake "master secret" - updateHandshake "master secret" (\hst ->- let ms = generateMasterSecret (stVersion st) premastersecret (hstClientRandom hst) (fromJust "server random" $ hstServerRandom hst) in- hst { hstMasterSecret = Just ms } )+ updateHandshake "master secret" (\hst -> hst { hstMasterSecret = Just masterSecret } )+ setKeyBlock return () +setMasterSecretFromPre :: MonadState TLSState m => Bytes -> m ()+setMasterSecretFromPre premasterSecret = do+ hasValidHandshake "generate master secret"+ st <- get+ setMasterSecret $ genSecret st+ where+ genSecret st =+ let hst = fromJust "handshake" $ stHandshake st in+ generateMasterSecret (stVersion st)+ premasterSecret+ (hstClientRandom hst)+ (fromJust "server random" $ hstServerRandom hst)+ setPublicKey :: MonadState TLSState m => PublicKey -> m () setPublicKey pk = updateHandshake "publickey" (\hst -> hst { hstRSAPublicKey = Just pk }) setPrivateKey :: MonadState TLSState m => PrivateKey -> m () setPrivateKey pk = updateHandshake "privatekey" (\hst -> hst { hstRSAPrivateKey = Just pk })++getSessionData :: MonadState TLSState m => m (Maybe SessionData)+getSessionData = do+ st <- get+ return (stHandshake st >>= hstMasterSecret >>= wrapSessionData st)+ where wrapSessionData st masterSecret = do+ return $ SessionData+ { sessionVersion = stVersion st+ , sessionCipher = cipherID $ fromJust "cipher" $ stCipher st+ , sessionSecret = masterSecret+ }++setSession :: MonadState TLSState m => Session -> Bool -> m ()+setSession session resuming = modify (\st -> st { stSession = session, stSessionResuming = resuming })++getSession :: MonadState TLSState m => m Session+getSession = gets stSession++isSessionResuming :: MonadState TLSState m => m Bool+isSessionResuming = gets stSessionResuming setKeyBlock :: MonadState TLSState m => m () setKeyBlock = do
Network/TLS/Struct.hs view
@@ -31,7 +31,9 @@ , serverRandom , clientRandom , FinishedData+ , SessionID , Session(..)+ , SessionData(..) , AlertLevel(..) , AlertDescription(..) , HandshakeType(..)@@ -56,8 +58,6 @@ -- | Versions known to TLS -- -- SSL2 is just defined, but this version is and will not be supported.------ TLS12 is not yet supported data Version = SSL2 | SSL3 | TLS10 | TLS11 | TLS12 deriving (Show, Eq, Ord) data ConnectionEnd = ConnectionServer | ConnectionClient@@ -140,7 +140,15 @@ newtype ServerRandom = ServerRandom Bytes deriving (Show, Eq) newtype ClientRandom = ClientRandom Bytes deriving (Show, Eq)-newtype Session = Session (Maybe Bytes) deriving (Show, Eq)+type SessionID = Bytes+newtype Session = Session (Maybe SessionID) deriving (Show, Eq)++data SessionData = SessionData+ { sessionVersion :: Version+ , sessionCipher :: CipherID+ , sessionSecret :: Bytes+ }+ type CipherID = Word16 type CompressionID = Word8 type FinishedData = Bytes
Tests.hs view
@@ -9,6 +9,7 @@ import Tests.PipeChan import Tests.Connection +import Data.Maybe import Data.Word import qualified Data.ByteString as B@@ -22,6 +23,8 @@ import Control.Exception (throw, catch, SomeException) import Control.Monad +import Data.IORef+ import Prelude hiding (catch) genByteString :: Int -> Gen B.ByteString@@ -68,6 +71,9 @@ arbitraryCompressionIDs :: Gen [Word8] arbitraryCompressionIDs = choose (0,200) >>= vector +someWords8 :: Int -> Gen [Word8]+someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))+ instance Arbitrary CertificateType where arbitrary = elements [ CertificateType_RSA_Sign, CertificateType_DSS_Sign@@ -131,20 +137,28 @@ return () -prop_handshake_initiate :: PropertyM IO ()-prop_handshake_initiate = do+establish_data_pipe params tlsServer tlsClient = do -- initial setup- pipe <- run newPipe- _ <- run (runPipe pipe)- startQueue <- run newChan- resultQueue <- run newChan+ pipe <- newPipe+ _ <- (runPipe pipe)+ startQueue <- newChan+ resultQueue <- newChan - params <- pick arbitraryPairParams- (cCtx, sCtx) <- run $ newPairContext pipe params+ (cCtx, sCtx) <- newPairContext pipe params - _ <- run $ forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")- _ <- run $ forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client")+ _ <- forkIO $ catch (tlsServer sCtx resultQueue) (printAndRaise "server")+ _ <- forkIO $ catch (tlsClient startQueue cCtx) (printAndRaise "client") + return (startQueue, resultQueue)+ where+ printAndRaise :: String -> SomeException -> IO ()+ printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e++prop_handshake_initiate :: PropertyM IO ()+prop_handshake_initiate = do+ params <- pick arbitraryPairParams+ (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient)+ {- 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)@@ -155,12 +169,35 @@ return () where- printAndRaise :: String -> SomeException -> IO ()- printAndRaise s e = putStrLn (s ++ " exception: " ++ show e) >> throw e+ 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 () - someWords8 :: Int -> Gen [Word8]- someWords8 i = replicateM i (fromIntegral <$> (choose (0,255) :: Gen Int))+prop_handshake_renegociation :: PropertyM IO ()+prop_handshake_renegociation = do+ params <- pick arbitraryPairParams+ (startQueue, resultQueue) <- run (establish_data_pipe params tlsServer tlsClient) + {- 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 tlsServer ctx queue = do hSuccess <- handshake ctx unless hSuccess $ fail "handshake failed on server side"@@ -170,11 +207,60 @@ tlsClient queue ctx = do hSuccess <- handshake ctx unless hSuccess $ fail "handshake failed on client side"+ hSuccess2 <- handshake ctx+ unless hSuccess2 $ fail "renegociation handshake failed" d <- readChan queue sendData ctx d bye ctx return () +prop_handshake_session_resumption :: PropertyM IO ()+prop_handshake_session_resumption = do+ sessionRef <- run $ newIORef Nothing++ plainParams <- pick arbitraryPairParams+ let params = setPairParamsSessionSaving (\sid d -> writeIORef sessionRef $ Just (sid,d)) plainParams++ -- establish a session.+ (s1, r1) <- run (establish_data_pipe params tlsServer tlsClient)++ d <- L.pack <$> pick (someWords8 256)+ run $ writeChan s1 d+ dres <- run $ readChan r1+ d `assertEq` dres++ -- and resume+ sessionParams <- run $ readIORef sessionRef+ assert (isJust sessionParams)+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) plainParams++ -- resume+ (startQueue, resultQueue) <- run (establish_data_pipe params2 tlsServer tlsClient)++ {- 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+ tlsServer ctx queue = do+ hSuccess <- handshake ctx+ unless hSuccess $ fail "resumption failed on server side"+ d <- recvData ctx+ writeChan queue d+ return ()+ tlsClient queue ctx = do+ hSuccess <- handshake ctx+ unless hSuccess $ fail "resumption 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) @@ -194,4 +280,6 @@ tests_handshake = testGroup "Handshakes" [ testProperty "setup" (monadicIO prop_pipe_work) , testProperty "initiate" (monadicIO prop_handshake_initiate)+ , testProperty "renegociation" (monadicIO prop_handshake_renegociation)+ , testProperty "resumption" (monadicIO prop_handshake_session_resumption) ]
tls.cabal view
@@ -1,5 +1,5 @@ Name: tls-Version: 0.8.3.2+Version: 0.8.4 Description: Native Haskell TLS and SSL protocol implementation for server and client. .