tls 2.2.1 → 2.2.2
raw patch · 31 files changed
+334/−235 lines, 31 filesdep ~cryptondep ~hpke
Dependency ranges changed: crypton, hpke
Files
- CHANGELOG.md +7/−0
- Network/TLS/Context.hs +1/−1
- Network/TLS/Context/Internal.hs +6/−4
- Network/TLS/Core.hs +37/−34
- Network/TLS/Crypto.hs +1/−0
- Network/TLS/Handshake.hs +3/−3
- Network/TLS/Handshake/Client.hs +5/−4
- Network/TLS/Handshake/Client/ClientHello.hs +16/−9
- Network/TLS/Handshake/Client/ServerHello.hs +6/−6
- Network/TLS/Handshake/Client/TLS12.hs +7/−6
- Network/TLS/Handshake/Client/TLS13.hs +21/−17
- Network/TLS/Handshake/Common.hs +18/−14
- Network/TLS/Handshake/Common13.hs +15/−13
- Network/TLS/Handshake/Server.hs +15/−8
- Network/TLS/Handshake/Server/ClientHello.hs +12/−9
- Network/TLS/Handshake/Server/ClientHello12.hs +0/−2
- Network/TLS/Handshake/Server/ClientHello13.hs +8/−10
- Network/TLS/Handshake/Server/ServerHello12.hs +2/−2
- Network/TLS/Handshake/Server/ServerHello13.hs +12/−12
- Network/TLS/Handshake/Server/TLS12.hs +1/−1
- Network/TLS/Handshake/Server/TLS13.hs +24/−20
- Network/TLS/Handshake/State.hs +5/−5
- Network/TLS/Handshake/TranscriptHash.hs +7/−7
- Network/TLS/IO.hs +11/−9
- Network/TLS/IO/Decode.hs +34/−18
- Network/TLS/IO/Encode.hs +37/−11
- Network/TLS/State.hs +7/−5
- Network/TLS/Struct.hs +6/−3
- Network/TLS/Struct13.hs +4/−1
- Network/TLS/Types.hs +5/−0
- tls.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Change log for "tls" +## Version 2.2.2++* A new architecture to calculate receiver's transcript hash with wire+ format.+ [#515](https://github.com/haskell-tls/hs-tls/pull/515)+* Enabling compressed certificate on the client side again.+ ## Version 2.2.1 * Disabling compressed certificate on the client side.
Network/TLS/Context.hs view
@@ -112,7 +112,7 @@ getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO ()- doHandshakeWith :: a -> Context -> Handshake -> IO ()+ doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO ()
Network/TLS/Context/Internal.hs view
@@ -166,7 +166,7 @@ data RoleParams = RoleParams { doHandshake_ :: Context -> IO ()- , doHandshakeWith_ :: Context -> Handshake -> IO ()+ , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () }@@ -271,11 +271,13 @@ data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment.- -- The second bool is update transcript hash.- PendingRecvAction Bool Bool (Handshake13 -> IO ())+ PendingRecvAction Bool (Handshake13 -> IO ())+ | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment.- PendingRecvActionHash Bool (TranscriptHash -> Handshake13 -> IO ())+ PendingRecvActionHash+ Bool+ (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)
Network/TLS/Core.hs view
@@ -212,10 +212,10 @@ pkt <- recvPacket12 ctx either (onError terminate12) process pkt where- process (Handshake [ch@ClientHello{}]) =- handshakeWith ctx ch >> recvData12 ctx- process (Handshake [hr@HelloRequest]) =- handshakeWith ctx hr >> recvData12 ctx+ process (Handshake [ch@ClientHello{}] [b]) =+ handshakeWith ctx (ch, b) >> recvData12 ctx+ process (Handshake [hr@HelloRequest] [b]) =+ handshakeWith ctx (hr, b) >> recvData12 ctx -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty@@ -260,8 +260,8 @@ ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc) )- process (Handshake13 hs) = do- loopHandshake13 hs+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. process (AppData13 "") = recvData13 ctx@@ -299,7 +299,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment.- loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"@@ -328,16 +328,16 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}- loopHandshake13 hs- loopHandshake13 (KeyUpdate13 mode : hs) = do- let multipleKeyUpdate = any isKeyUpdate13 hs+ loopHandshake13 hbs+ loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+ let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs when multipleKeyUpdate $ do let reason = "Multiple KeyUpdate is not allowed in one record" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- checkAlignment ctx hs+ checkAlignment ctx established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -350,16 +350,16 @@ -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState- loopHandshake13 hs+ loopHandshake13 hbs else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- Client only- loopHandshake13 (h@CertRequest13{} : hs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hs- loopHandshake13 (h : hs) = do+ loopHandshake13 ((h@CertRequest13{}, _b) : hbs) =+ postHandshakeAuthWith ctx h >> loopHandshake13 hbs+ loopHandshake13 (hb@(h, _) : hbs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of ServerHello13 SH{..} ->@@ -368,8 +368,8 @@ let reason = "HRR is not allowed for 0-RTT" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return ()- cont <- popAction ctx h hs- when cont $ loopHandshake13 hs+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do@@ -380,8 +380,8 @@ -- UserCanceled MUST be followed by a CloseNotify. process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx- process (Handshake13 hs) = do- loopHandshake13 hs+ process (Handshake13 hs bs) = do+ loopHandshake13 $ zip hs bs stop <- breakLoop unless stop $ recvHS13 ctx breakLoop process _ = recvHS13 ctx breakLoop@@ -389,7 +389,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment.- loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do+ loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only"@@ -415,17 +415,17 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}- loopHandshake13 hs- loopHandshake13 (h : hs) = do- cont <- popAction ctx h hs- when cont $ loopHandshake13 hs+ loopHandshake13 hbs+ loopHandshake13 (hb : hbs) = do+ cont <- popAction ctx hb+ when cont $ loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool-popAction ctx h hs = do+popAction :: Context -> Handshake13R -> IO Bool+popAction ctx hb@(h, _b) = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of Nothing -> return False@@ -435,14 +435,17 @@ withWriteLock ctx $ handleException ctx $ do case action of- PendingRecvAction needAligned update pa -> do- when needAligned $ checkAlignment ctx hs- when update $ void $ updateTranscriptHash13 ctx h+ PendingRecvAction needAligned pa -> do+ when needAligned $ checkAlignment ctx+ updateTranscriptHash13 ctx hb pa h+ PendingRecvActionSelfUpdate needAligned pa -> do+ when needAligned $ checkAlignment ctx+ pa hb PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment ctx hs+ when needAligned $ checkAlignment ctx d <- transcriptHash ctx "Pending action"- void $ updateTranscriptHash13 ctx h+ updateTranscriptHash13 ctx hb pa d h -- Client: after receiving SH, app data is coming. -- this loop tries to receive it.@@ -451,8 +454,8 @@ sendCFifNecessary ctx return True -checkAlignment :: Context -> [Handshake13] -> IO ()-checkAlignment ctx _hs = do+checkAlignment :: Context -> IO ()+checkAlignment ctx = do complete <- isRecvComplete ctx unless complete $ do let reason = "received message not aligned with record boundary"
Network/TLS/Crypto.hs view
@@ -7,6 +7,7 @@ HashCtx, hashInit, hashUpdate,+ hashUpdates, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH,
Network/TLS/Handshake.hs view
@@ -25,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock.-handshakeWith :: MonadIO m => Context -> Handshake -> m ()-handshakeWith ctx hs =+handshakeWith :: MonadIO m => Context -> HandshakeR -> m ()+handshakeWith ctx hsr = liftIO $ withWriteLock ctx $ handleException ctx $- doHandshakeWith_ (ctxRoleParams ctx) ctx hs+ doHandshakeWith_ (ctxRoleParams ctx) ctx hsr
Network/TLS/Handshake/Client.hs view
@@ -26,8 +26,9 @@ ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()-handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx+handshakeClientWith+ :: ClientParams -> Context -> HandshakeR -> IO ()+handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ = throwCore $ Error_Protocol@@ -76,7 +77,7 @@ -------------------------------- -- Receiving ServerHello unless async $ do- (ver, hss, hrr) <- receiveServerHello cparams ctx mparams+ (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams -------------------------------- -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of@@ -93,7 +94,7 @@ "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do- recvServerFirstFlight12 cparams ctx hss+ recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx recvServerSecondFlight12 cparams ctx where
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -127,17 +127,22 @@ Nothing -> do if hrr then do- chI <- fromJust <$> usingHState ctx getClientHello+ (chI, _) <- fromJust <$> usingHState ctx getClientHello let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)}- usingHState ctx $ setClientHello ch0'+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' [] return ch0' else do gEchExt <- greasingEchExt let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)}- usingHState ctx $ setClientHello ch0'+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0' [] return ch0' Just echParams -> do- usingHState ctx $ setClientHello ch0+ let encoded = encodeHandshake $ ClientHello ch0+ usingHState ctx $ setClientHello ch0 [encoded] mcrandO <- usingHState ctx getOuterClientRandom crandO <- case mcrandO of Nothing -> clientRandom ctx@@ -148,9 +153,11 @@ mpskExt <- randomPreSharedKeyExt createEncryptedClientHello ctx ch0 echParams crandO mpskExt else do- usingHState ctx $ setClientHello ch0+ -- [] will be overridden via+ -- encodeUpdateTranscriptHash12+ usingHState ctx $ setClientHello ch0 [] return ch0- sendPacket12 ctx $ Handshake [ClientHello ch]+ sendPacket12 ctx $ Handshake [ClientHello ch] [] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info@@ -181,8 +188,8 @@ , {- 0x0d -} signatureAlgExt , {- 0x10 -} alpnExt , {- 0x17 -} emsExt- , -- , {- 0x1b -} compCertExt- {- 0x1c -} recordSizeLimitExt+ , {- 0x1b -} compCertExt+ , {- 0x1c -} recordSizeLimitExt , {- 0x23 -} sessionTicketExt , {- 0x2a -} earlyDataExt , {- 0x2b -} versionExt@@ -238,7 +245,7 @@ then Nothing else Just $ toExtensionRaw ExtendedMainSecret - -- compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib])+ compCertExt = return $ Just $ toExtensionRaw (CompressCertificate [CCA_Zlib]) recordSizeLimitExt = case limitRecordSize $ sharedLimit $ ctxShared ctx of Nothing -> return Nothing
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -35,12 +35,12 @@ :: ClientParams -> Context -> Maybe (ClientRandom, Session, Version)- -> IO (Version, [Handshake], Bool)+ -> IO (Version, [HandshakeR], Bool) receiveServerHello cparams ctx mparams = do chSentTime <- getCurrentTimeFromBase- (sh, hss) <- recvSH+ (shb@(sh, _), hbs) <- recvSH processServerHello cparams ctx sh- void $ updateTranscriptHash12 ctx sh+ updateTranscriptHash12 ctx shb setRTT ctx chSentTime ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $@@ -51,7 +51,7 @@ -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR- return (ver, hss, hrr)+ return (ver, hbs, hrr) where recvSH = do epkt <- recvPacket12 ctx@@ -59,7 +59,7 @@ Left e -> throwCore e Right pkt -> case pkt of Alert a -> throwAlert a- Handshake (h : hs) -> return (h, hs)+ Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs) _ -> unexpected (show pkt) (Just "handshake") throwAlert a = throwCore $@@ -179,7 +179,7 @@ transitTranscriptHashI ctx "transitI" usedHash isHRR accepted <- checkECHacceptance ctx isHRR usedHash sh when accepted $ do- CH{..} <- fromJust <$> usingHState ctx getClientHello+ (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello usingHState ctx $ setClientRandom chRandom -- inner random when (accepted && not isHRR) $ do copyTranscriptHash ctx "copy"
Network/TLS/Handshake/Client/TLS12.hs view
@@ -32,14 +32,15 @@ ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()-recvServerFirstFlight12 cparams ctx hs = do+recvServerFirstFlight12+ :: ClientParams -> Context -> [HandshakeR] -> IO ()+recvServerFirstFlight12 cparams ctx hbs = do resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx)- runRecvStateHS ctx st hs+ runRecvStateHS ctx st hbs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do@@ -151,7 +152,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True- sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)]+ sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] [] ---------------------------------------------------------------- @@ -167,7 +168,7 @@ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure- sendPacket12 ctx $ Handshake [ClientKeyXchg ckx]+ sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] [] mainSecret <- usingHState ctx setMainSec logKey ctx (MainSecret mainSecret) @@ -283,4 +284,4 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs- sendPacket12 ctx $ Handshake [CertVerify sigDig]+ sendPacket12 ctx $ Handshake [CertVerify sigDig] []
Network/TLS/Handshake/Client/TLS13.hs view
@@ -147,12 +147,13 @@ Nothing -> do usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected-expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions")+expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx $ expectCertAndVerify cparams ctx@@ -211,10 +212,11 @@ ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify- :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+ :: MonadIO m+ => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc-expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate")+expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate") processCertAndVerify :: MonadIO m@@ -231,11 +233,12 @@ ---------------------------------------------------------------- expectCertVerify- :: MonadIO m => Context -> PubKey -> TranscriptHash -> Handshake13 -> m ()+ :: MonadIO m+ => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify"-expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify")+expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify") ---------------------------------------------------------------- @@ -290,7 +293,7 @@ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $- sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+ sendPacket13 ctx (Handshake13 [EndOfEarlyData13] []) let clientHandshakeSecret = triClient hkey setTxRecordState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret@@ -344,7 +347,7 @@ certComp <- usingHState ctx getTLS13CertComp loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True}@@ -355,7 +358,7 @@ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx let certtag = if certComp then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [certtag token (CertificateChain_ chain) certExts]+ Handshake13 [certtag token (CertificateChain_ chain) certExts] [] case certs of [] -> return () _ -> do@@ -364,7 +367,7 @@ sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc- loadPacket13 ctx $ Handshake13 [vfy]+ loadPacket13 ctx $ Handshake13 [vfy] [] -- loadClientData13 _ _ _ = throwCore $@@ -373,10 +376,11 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =+postHandshakeAuthClientWith+ :: ClientParams -> Context -> Handshake13 -> IO ()+postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- void $ updateTranscriptHash13 ctx h+ -- updateTranscriptHash13 ctx h b processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $@@ -403,15 +407,15 @@ asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx- [ PendingRecvAction True False expectServerHello- , PendingRecvAction True True (expectEncryptedExtensions ctx)+ [ PendingRecvActionSelfUpdate True expectServerHello+ , PendingRecvAction True (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] where- expectServerHello sh = do+ expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh- void $ updateTranscriptHash13 ctx sh -- update by myself+ updateTranscriptHash13 ctx shb -- update by myself void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do expectFinished cparams ctx h sf
Network/TLS/Handshake/Common.hs view
@@ -31,6 +31,7 @@ -- setPeerRecordSizeLimit, generateFinished,+ encodeUpdateTranscriptHash12, updateTranscriptHash12, -- startHandshake,@@ -132,7 +133,7 @@ enablePeerRecordLimit ctx ver <- usingState_ ctx getVersion verifyData <- VerifyData <$> generateFinished ctx ver role- sendPacket12 ctx (Handshake [Finished verifyData])+ sendPacket12 ctx (Handshake [Finished verifyData] []) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -141,11 +142,11 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake]+recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do pkts <- recvPacket12 ctx case pkts of- Right (Handshake l) -> return l+ Right (Handshake hss bss) -> return $ zip hss bss Right x@(AppData _) -> do -- If a TLS13 server decides to reject RTT0 data, the server should -- skip records for RTT0 data up to the maximum limit.@@ -161,16 +162,18 @@ -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake- :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)+ :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState-onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms)-onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do- let finished = isFinished x- unless finished $ void $ updateTranscriptHash12 ctx x- nstate <- f x- when finished $ void $ updateTranscriptHash12 ctx x- onRecvStateHandshake ctx nstate xs-onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing+onRecvStateHandshake _ (RecvStatePacket f) hbs = do+ let (hss, bss) = unzip hbs+ f (Handshake hss bss)+onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do+ let finished = isFinished h+ unless finished $ void $ updateTranscriptHash12 ctx hb+ nstate <- f h+ when finished $ void $ updateTranscriptHash12 ctx hb+ onRecvStateHandshake ctx nstate hbs+onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True@@ -184,8 +187,9 @@ >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()-runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx+runRecvStateHS+ :: Context -> RecvState IO -> [HandshakeR] -> IO ()+runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do
Network/TLS/Handshake/Common13.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -68,7 +69,6 @@ import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC-import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State@@ -373,7 +373,8 @@ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+newtype RecvHandshake13M m a+ = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13@@ -381,7 +382,7 @@ => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a-recvHandshake13 ctx f = getHandshake13 ctx >>= f+recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h recvHandshake13hash :: MonadIO m@@ -391,21 +392,22 @@ -> RecvHandshake13M m a recvHandshake13hash ctx label f = do d <- transcriptHash ctx label- getHandshake13 ctx >>= f d+ getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13+getHandshake13+ :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of- (h : hs) -> found h hs- [] -> recvLoop+ hb : hbs -> found hb hbs+ _ -> recvLoop where- found h hs = liftIO (void $ updateTranscriptHash13 ctx h) >> put hs >> return h+ found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of- Right (Handshake13 []) -> error "invalid recvPacket13 result"- Right (Handshake13 (h : hs)) -> found h hs+ Right (Handshake13 [] _) -> error "invalid recvPacket13 result"+ Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs Right ChangeCipherSpec13 -> do alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv if alreadyReceived@@ -462,8 +464,8 @@ -> Either ByteString (BaseSecret EarlySecret) -> IO (SecretPair EarlySecret) calculateEarlySecret ctx choice maux = do- ch <- fromJust <$> usingHState ctx getClientHello- let hCh = TranscriptHash $ hash usedHash $ encodeHandshake $ ClientHello ch+ (_ch, b) <- fromJust <$> usingHState ctx getClientHello+ let hCh = TranscriptHash $ hashChunks usedHash b let earlySecret = case maux of Right (BaseSecret sec) -> sec Left psk -> hkdfExtract usedHash zero psk@@ -591,7 +593,7 @@ :: (MonadFail m, MonadIO m) => Context -> Hash -> ServerHello -> ByteString -> m ByteString computeConfirm ctx usedHash sh label = do- CH{..} <- fromJust <$> liftIO (usingHState ctx getClientHello)+ (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello) TranscriptHash echConf <- transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh let prk = hkdfExtract usedHash "" $ unClientRandom chRandom
Network/TLS/Handshake/Server.hs view
@@ -31,12 +31,13 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do- hss <- recvPacketHandshake ctx- case hss of- [ch] -> handshake sparams ctx ch- _ -> unexpected (show hss) (Just "client hello")+ hbs <- recvPacketHandshake ctx+ case hbs of+ chb : _ -> handshake sparams ctx chb+ _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()+handshakeServerWith+ :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake -- | Put the server context in handshake mode.@@ -46,13 +47,14 @@ -- -- When the function returns, a new handshake has been succesfully negociated. -- On any error, a HandshakeFailed exception is raised.-handshake :: ServerParams -> Context -> Handshake -> IO ()-handshake sparams ctx (ClientHello ch) = do- (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch+handshake :: ServerParams -> Context -> HandshakeR -> IO ()+handshake sparams ctx chb@(ClientHello ch, bs) = do+ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry.+ -- r0 :: Cipher, Hash, Bool (mClientKeyShare, r0, r1) <- processClientHello13 sparams ctx chI case mClientKeyShare of@@ -62,12 +64,17 @@ -- would be comming, which should be ignored. handshakeServer sparams ctx Just cliKeyShare -> do+ -- r2 :: ( SecretTriple ApplicationSecret+ -- , ClientTrafficSecret HandshakeSecret+ -- , Bool -- authenticated+ -- , Bool) -- rtt0OK r2 <- sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd recvClientSecondFlight13 sparams ctx r2 chI else do r <- processClientHello12 sparams ctx chI+ updateTranscriptHash12 ctx chb resumeSessionData <- sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -29,12 +29,13 @@ :: ServerParams -> Context -> ClientHello+ -> [ByteString] -> IO ( Version , ClientHello , Maybe ClientRandom -- Just for ECH to keep the outer one for key log )-processClientHello sparams ctx ch@CH{..} = do+processClientHello sparams ctx ch@CH{..} b = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do@@ -127,10 +128,12 @@ else return (Nothing, False) case mClientHello' of Just chI -> do- setupI ctx chI+ -- chI is created from diff.+ -- encodeHandshake is a MUST.+ setupI ctx chI $ [encodeHandshake $ ClientHello chI] return (chosenVersion, chI, Just chRandom) _ -> do- setupO ctx ch+ setupO ctx ch b when (chosenVersion == TLS13) $ do let hasECHConf = not (null (sharedECHConfigList (serverShared sparams))) when (hasECHConf && not receivedECH) $@@ -141,19 +144,19 @@ setECHEE True return (chosenVersion, ch, Nothing) -setupI :: Context -> ClientHello -> IO ()-setupI ctx chI@CH{..} = do+setupI :: Context -> ClientHello -> [ByteString] -> IO ()+setupI ctx chI@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx TLS13 chRandom- usingHState ctx $ setClientHello chI+ usingHState ctx $ setClientHello chI b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName -setupO :: Context -> ClientHello -> IO ()-setupO ctx ch@CH{..} = do+setupO :: Context -> ClientHello -> [ByteString] -> IO ()+setupO ctx ch@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx chVersion chRandom- usingHState ctx $ setClientHello ch+ usingHState ctx $ setClientHello ch b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -13,7 +13,6 @@ import Network.TLS.Extension import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature-import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.State@@ -46,7 +45,6 @@ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds- void $ updateTranscriptHash12 ctx $ ClientHello ch return (usedCipher, mcred) checkSecureRenegotiation :: Context -> ClientHello -> IO ()
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -16,7 +16,6 @@ import Network.TLS.Handshake.State import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State@@ -30,8 +29,8 @@ -> ClientHello -> IO ( Maybe KeyShareEntry- , (Cipher, Hash, Bool)- , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+ , (Cipher, Hash, Bool) -- rtt0+ , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid ) processClientHello13 sparams ctx ch@CH{..} = do when@@ -76,8 +75,8 @@ mshare <- findKeyShare keyShares serverGroups let triple = (usedCipher, usedHash, rtt0) pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch- clientHello <- fromJust <$> usingHState ctx getClientHello- void $ updateTranscriptHash12 ctx $ ClientHello clientHello+ (ich, b) <- fromJust <$> usingHState ctx getClientHello+ updateTranscriptHash12 ctx (ClientHello ich, b) return (mshare, triple, pskEarlySecret) where ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers@@ -104,9 +103,9 @@ pskAndEarlySecret :: ServerParams -> Context- -> (Cipher, Hash, Bool)+ -> (Cipher, Hash, Bool) -- rtt0 -> ClientHello- -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+ -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk)@@ -156,9 +155,8 @@ checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do- ch <- fromJust <$> usingHState ctx getClientHello- let ech = encodeHandshake $ ClientHello ch- binder' = makePSKBinder earlySecret usedHash tlen ech+ (_, b) <- fromJust <$> usingHState ctx getClientHello+ let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx unless (binder == binder') $ decryptError "PSK binder validation failed" return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -42,7 +42,7 @@ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions let ff = ServerHello sh : build [ServerHelloDone]- sendPacket12 ctx $ Handshake ff+ sendPacket12 ctx $ Handshake ff [] contextFlush ctx Just sessionData -> do usingState_ ctx $ do@@ -50,7 +50,7 @@ setTLS12SessionResuming True sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession- sendPacket12 ctx $ Handshake [ServerHello sh]+ sendPacket12 ctx $ Handshake [ServerHello sh] [] let mainSecret = sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -36,15 +36,15 @@ :: ServerParams -> Context -> KeyShareEntry- -> (Cipher, Hash, Bool)- -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+ -> (Cipher, Hash, Bool) -- rtt0+ -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid -> ClientHello -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret- , Bool- , Bool+ , Bool -- authenticated+ , Bool -- rtt0OK ) sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do let clientEarlySecret = pairClient earlyKey@@ -120,7 +120,7 @@ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs- loadPacket13 ctx $ Handshake13 [rawFinished]+ loadPacket13 ctx $ Handshake13 [rawFinished] [] return (clientHandshakeSecret, handSecret) ---------------------------------------------------------------- hChSf <- transcriptHash ctx "CH..SF"@@ -204,7 +204,7 @@ , shExtensions = shExts } usingHState ctx $ setECHAccepted True- loadPacket13 ctx $ Handshake13 [ServerHello13 sh']+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] [] else do srand <- liftIO $@@ -220,26 +220,26 @@ , shComp = 0 , shExtensions = shExts }- loadPacket13 ctx $ Handshake13 [ServerHello13 sh]+ loadPacket13 ctx $ Handshake13 [ServerHello13 sh] [] sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here. certReq = makeCertRequest sparams ctx certReqCtx True- loadPacket13 ctx $ Handshake13 [certReq]+ loadPacket13 ctx $ Handshake13 [certReq] [] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) [] let certtag = if zlib then CompressedCertificate13 else Certificate13 loadPacket13 ctx $- Handshake13 [certtag "" (CertificateChain_ certChain) ess]+ Handshake13 [certtag "" (CertificateChain_ certChain) ess] [] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc- loadPacket13 ctx $ Handshake13 [vrfy]+ loadPacket13 ctx $ Handshake13 [vrfy] [] sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI@@ -285,7 +285,7 @@ ] eeExtensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions- loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions']+ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]@@ -337,7 +337,7 @@ hrr <- makeHRR ctx usedCipher usedHash chSession g isEch usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [ServerHello13 hrr]+ loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] [] sendChangeCipherSpec13 ctx where serverGroups = supportedGroups (ctxSupported ctx)
Network/TLS/Handshake/Server/TLS12.hs view
@@ -40,7 +40,7 @@ Nothing -> return () Just ticket -> do let life = adjustLifetime $ serverTicketLifetime sparams- sendPacket12 ctx $ Handshake [NewSessionTicket life ticket]+ sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] [] sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx
Network/TLS/Handshake/Server/TLS13.hs view
@@ -71,7 +71,7 @@ then setPendingRecvActions ctx- [ PendingRecvAction True True $ expectEndOfEarlyData ctx clientHandshakeSecret+ [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret , PendingRecvActionHash True $ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ]@@ -104,7 +104,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") expectEndOfEarlyData- :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()+ :: Context+ -> ClientTrafficSecret HandshakeSecret+ -> Handshake13+ -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do (usedHash, usedCipher, _, _) <- getRxRecordState ctx setRxRecordState ctx usedHash usedCipher clientHandshakeSecret@@ -145,7 +148,7 @@ psk = derivePSK choice resumptionSecret nonce (identity, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce identity rtt0max- sendPacket13 ctx $ Handshake13 [nst]+ sendPacket13 ctx $ Handshake13 [nst] [] where choice = makeCipherChoice TLS13 usedCipher rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams@@ -179,7 +182,8 @@ | otherwise = fromIntegral i expectCertVerify- :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()+ :: MonadIO m+ => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "invalid client certificate chain"@@ -237,26 +241,26 @@ let certReq13 = makeCertRequest sparams ctx origCertReqCtx False _ <- withWriteLock ctx $ do bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- sendPacket13 ctx $ Handshake13 [certReq13]+ sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do- clientCert13 <- getHandshake ctx ref+ (clientCert13, bClientCert13) <- getHandshake ctx ref emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13 baseHState <- saveHState ctx- void $ updateTranscriptHash13 ctx certReq13- void $ updateTranscriptHash13 ctx clientCert13+ updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert" unless emptyCert $ do- certVerify13 <- getHandshake ctx ref+ (certVerify13, bCertVerify13) <- getHandshake ctx ref expectCertVerify sparams ctx th certVerify13- void $ updateTranscriptHash13 ctx certVerify13- finished13 <- getHandshake ctx ref+ updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+ (finished13, _bFinished13) <- getHandshake ctx ref expectClientFinished ctx finished13 void $ restoreHState ctx baseHState -- fixme return True -- saving appdata and key update? -- error handling-getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13+getHandshake+ :: Context -> IORef [Handshake13R] -> IO Handshake13R getHandshake ctx ref = do hhs <- readIORef ref if null hhs@@ -265,23 +269,23 @@ either (terminate ctx) process ex else chk hhs where- process (Handshake13 iss) = chk iss+ process (Handshake13 hss bss) = chk $ zip hss bss process _ = terminate ctx $ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref- chk (KeyUpdate13 mode : hs) = do+ chk ((KeyUpdate13 mode, _) : hbs) = do keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState- chk hs- chk (h : hs) = do- writeIORef ref hs- return h+ chk hbs+ chk (hb : hbs) = do+ writeIORef ref hbs+ return hb expectClientCertificate :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool@@ -379,6 +383,6 @@ -- Write lock wraps both actions because we don't want another packet to -- be sent by another thread before the Tx state is updated. withWriteLock ctx $ do- sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]+ sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] [] keyUpdate ctx getTxRecordState setTxRecordState return tls13
Network/TLS/Handshake/State.hs view
@@ -104,7 +104,7 @@ = -- | Initial state TransHashState0 | -- | A raw CH is stored since hash algo is not chosen yet.- TransHashState1 ByteString+ TransHashState1 [ByteString] | -- | Hashed TransHashState2 HashCtx @@ -161,7 +161,7 @@ , hstCCS13Recv :: Bool , hstTLS13OuterClientRandom :: Maybe ClientRandom -- ^ Used for key logging in the case of ECH.- , hstTLS13ClientHello :: Maybe ClientHello+ , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString]) -- ^ Inner client hello in the case of ECH. , hstTLS13ECHAccepted :: Bool , hstTLS13ECHEE :: Bool@@ -403,11 +403,11 @@ setOuterClientRandom :: Maybe ClientRandom -> HandshakeM () setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr}) -getClientHello :: HandshakeM (Maybe ClientHello)+getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString])) getClientHello = gets hstTLS13ClientHello -setClientHello :: ClientHello -> HandshakeM ()-setClientHello ch = modify' $ \hst -> hst{hstTLS13ClientHello = Just ch}+setClientHello :: ClientHello -> [ByteString] -> HandshakeM ()+setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)} getECHAccepted :: HandshakeM Bool getECHAccepted = gets hstTLS13ECHAccepted
Network/TLS/Handshake/TranscriptHash.hs view
@@ -40,11 +40,11 @@ transit :: String -> Hash -> Bool -> TransHashState -> TransHashState transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0 transit _ _ _ st2@(TransHashState2 _) = st2-transit _ hashAlg isHRR (TransHashState1 ch)- | isHRR = TransHashState2 $ newWith hsMsg- | otherwise = TransHashState2 $ newWith ch+transit _ hashAlg isHRR (TransHashState1 chs)+ | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg+ | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch where- newWith = hashUpdate $ hashInit hashAlg+ ch = reverse chs hsMsg = -- Handshake message: -- typ <-len-> body@@ -55,7 +55,7 @@ , hashedCH ] where- hashedCH = hash hashAlg ch+ hashedCH = hashChunks hashAlg ch len = fromIntegral $ B.length hashedCH ----------------------------------------------------------------@@ -73,9 +73,9 @@ traceTranscriptHash ctx label hstTransHashStateI update :: ByteString -> String -> TransHashState -> TransHashState-update eh _ TransHashState0 = TransHashState1 eh+update eh _ TransHashState0 = TransHashState1 [eh]+update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss) update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh-update _ label st = error $ "updateTranscriptHash " ++ label ++ " " ++ show st ----------------------------------------------------------------
Network/TLS/IO.hs view
@@ -114,9 +114,10 @@ -- stHandshakeRecordCont loop (count + 1) else case pktRecv of- Right (Handshake hss) -> do- pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->- Right . Handshake <$> mapM (hookRecvHandshake hooks) hss+ Right (Handshake hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake hooks) hss+ return $ Right $ Handshake hss' bss logPacket ctx $ show pkt return pktRecv' Right pkt -> do@@ -131,7 +132,7 @@ isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool-isEmptyHandshake (Right (Handshake [])) = True+isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False logPacket :: Context -> String -> IO ()@@ -174,9 +175,10 @@ loop (count + 1) else do case pktRecv of- Right (Handshake13 hss) -> do- pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->- Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss+ Right (Handshake13 hss bss) -> do+ pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+ hss' <- mapM (hookRecvHandshake13 hooks) hss+ return $ Right $ Handshake13 hss' bss logPacket ctx $ show pkt return pktRecv' Right pkt -> do@@ -187,7 +189,7 @@ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool-isEmptyHandshake13 (Right (Handshake13 [])) = True+isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False ----------------------------------------------------------------@@ -196,7 +198,7 @@ isRecvComplete ctx = usingState_ ctx $ do cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13- return $ isNothing cont12 && isNothing cont13+ return $ isNothing (fst cont12) && isNothing (fst cont13) checkValid :: Context -> IO () checkValid ctx = do
Network/TLS/IO/Decode.hs view
@@ -7,6 +7,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict+import qualified Data.ByteString as BS import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -41,22 +42,30 @@ , cParamsKeyXchgType = keyxchg } -- get back the optional continuation, and parse as many handshake record as possible.- mCont <- gets stHandshakeRecordCont12- modify' (\st -> st{stHandshakeRecordCont12 = Nothing})- hss <- parseMany currentParams mCont (fragmentGetBytes fragment)- return $ Handshake hss+ (mCont, wirebytes) <- gets stHandshakeRecordCont12+ modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])})+ (hss, bss) <-+ unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake hss bss where- parseMany currentParams mCont bs =+ parseMany currentParams mCont wirebytes bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err- GotPartial cont ->- modify' (\st -> st{stHandshakeRecordCont12 = Just cont}) >> return []+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)})+ return [] GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake currentParams ty content+ case decodeHandshake currentParams ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err- Right hh -> (hh :) <$> parseMany currentParams Nothing left+ Right h -> do+ hbs <- parseMany currentParams Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") switchRxEncryption :: Context -> IO ()@@ -74,20 +83,27 @@ decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do- mCont <- gets stHandshakeRecordCont13- modify' (\st -> st{stHandshakeRecordCont13 = Nothing})- hss <- parseMany mCont (fragmentGetBytes fragment)- return $ Handshake13 hss+ (mCont, wirebytes) <- gets stHandshakeRecordCont13+ modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})+ (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment)+ return $ Handshake13 hss bss where- parseMany mCont bs =+ parseMany mCont wirebytes bs = case fromMaybe decodeHandshakeRecord13 mCont bs of GotError err -> throwError err- GotPartial cont ->- modify' (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []+ GotPartial cont -> do+ modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)})+ return [] GotSuccess (ty, content) ->- either throwError (return . (: [])) $ decodeHandshake13 ty content+ case decodeHandshake13 ty content of+ Left err -> throwError err+ Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> case decodeHandshake13 ty content of Left err -> throwError err- Right hh -> (hh :) <$> parseMany Nothing left+ Right h -> do+ hbs <- parseMany Nothing [] left+ let len = BS.length bs - BS.length left+ bs' = BS.take len bs+ return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")
Network/TLS/IO/Encode.hs view
@@ -2,7 +2,9 @@ encodePacket12, encodePacket13, updateTranscriptHash12,+ encodeUpdateTranscriptHash12, updateTranscriptHash13,+ encodeUpdateTranscriptHash13, ) where import Control.Concurrent.MVar@@ -47,8 +49,8 @@ -- packets are not fragmented here but by callers of sendPacket, so that the -- empty-packet countermeasure may be applied to each fragment independently. packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments12 ctx mlen (Handshake hss) =- getChunks mlen . B.concat <$> mapM (updateTranscriptHash12 ctx) hss+packetToFragments12 ctx mlen (Handshake hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x]@@ -73,17 +75,32 @@ where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) -updateTranscriptHash12 :: Context -> Handshake -> IO ByteString-updateTranscriptHash12 ctx hs = do+encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString+encodeUpdateTranscriptHash12 ctx hs = do when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded let label = show $ typeOfHandshake hs when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded+ when (isClientHello hs) $ do+ usingHState ctx $ do+ (ch, b) <- fromJust <$> getClientHello+ when (null b) $ setClientHello ch [encoded] return encoded where encoded = encodeHandshake hs+ isClientHello (ClientHello _) = True+ isClientHello _ = False +updateTranscriptHash12 :: Context -> HandshakeR -> IO ()+updateTranscriptHash12 ctx (hs, bss) = do+ when (certVerifyHandshakeMaterial hs) $+ usingHState ctx $+ mapM_ addHandshakeMessage bss+ let label = show $ typeOfHandshake hs+ when (finishedHandshakeMaterial hs) $ do+ mapM_ (updateTranscriptHash ctx label) bss+ ---------------------------------------------------------------- encodePacket13@@ -100,14 +117,14 @@ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx) packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]-packetToFragments13 ctx mlen (Handshake13 hss) =- getChunks mlen . B.concat <$> mapM (updateTranscriptHash13 ctx) hss+packetToFragments13 ctx mlen (Handshake13 hss _) =+ getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments13 _ _ (AppData13 x) = return [x] packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] -updateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString-updateTranscriptHash13 ctx hs+encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString+encodeUpdateTranscriptHash13 ctx hs | isIgnored hs = return encoded | otherwise = do let label = show $ typeOfHandshake13 hs@@ -117,6 +134,15 @@ where encoded = encodeHandshake13 hs - isIgnored NewSessionTicket13{} = True- isIgnored KeyUpdate13{} = True- isIgnored _ = False+updateTranscriptHash13 :: Context -> Handshake13R -> IO ()+updateTranscriptHash13 ctx (hs, bss)+ | isIgnored hs = return ()+ | otherwise = do+ let label = show $ typeOfHandshake13 hs+ mapM_ (updateTranscriptHash ctx label) bss+ usingHState ctx $ mapM_ addHandshakeMessage bss++isIgnored :: Handshake13 -> Bool+isIgnored NewSessionTicket13{} = True+isIgnored KeyUpdate13{} = True+isIgnored _ = False
Network/TLS/State.hs view
@@ -79,7 +79,7 @@ import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct-import Network.TLS.Types (HostName, Role (..), Ticket)+import Network.TLS.Types (HostName, Role (..), Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState@@ -93,8 +93,10 @@ stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301 , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol- , stHandshakeRecordCont12 :: Maybe (GetContinuation (HandshakeType, ByteString))- , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString))+ , stHandshakeRecordCont12+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+ , stHandshakeRecordCont13+ :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes) , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat]@@ -136,8 +138,8 @@ , stServerCertificateChain = Nothing , stExtensionALPN = False , stNegotiatedProtocol = Nothing- , stHandshakeRecordCont12 = Nothing- , stHandshakeRecordCont13 = Nothing+ , stHandshakeRecordCont12 = (Nothing, [])+ , stHandshakeRecordCont13 = (Nothing, []) , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing
Network/TLS/Struct.hs view
@@ -118,6 +118,7 @@ hrrRandom, ClientHello (..), ServerHello (..),+ HandshakeR, ) where import Data.X509 (@@ -231,14 +232,14 @@ ---------------------------------------------------------------- data Packet- = Handshake [Handshake]+ = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Eq) instance Show Packet where- show (Handshake hs) = "Handshake " ++ show hs+ show (Handshake hs _) = "Handshake " ++ show hs show (Alert as) = "Alert " ++ show as show ChangeCipherSpec = "ChangeCipherSpec" show (AppData bs) = "AppData " ++ showBytesHex bs@@ -478,7 +479,7 @@ {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType-packetType (Handshake _) = ProtocolType_Handshake+packetType (Handshake _ _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData@@ -496,3 +497,5 @@ typeOfHandshake Finished{} = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -}++type HandshakeR = (Handshake, WireBytes)
Network/TLS/Struct13.hs view
@@ -8,6 +8,7 @@ isKeyUpdate13, TicketNonce (..), SessionIDorTicket_ (..),+ Handshake13R, ) where import Network.TLS.Imports@@ -15,7 +16,7 @@ import Network.TLS.Types data Packet13- = Handshake13 [Handshake13]+ = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString@@ -76,3 +77,5 @@ isKeyUpdate13 :: Handshake13 -> Bool isKeyUpdate13 (KeyUpdate13 _) = True isKeyUpdate13 _ = False++type Handshake13R = (Handshake13, WireBytes)
Network/TLS/Types.hs view
@@ -12,6 +12,7 @@ bigNumFromInteger, defaultRecordSizeLimit, TranscriptHash (..),+ WireBytes, ) where import Network.Socket (HostName)@@ -64,3 +65,7 @@ instance Show TranscriptHash where show (TranscriptHash bs) = showBytesHex bs++----------------------------------------------------------------++type WireBytes = [ByteString]
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.2.1+version: 2.2.2 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>