tls 2.4.12 → 2.4.13
raw patch · 22 files changed
+559/−93 lines, 22 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.TLS: defaultSessionData :: SessionData
Files
- CHANGELOG.md +15/−0
- Network/TLS.hs +1/−0
- Network/TLS/Context/Internal.hs +20/−1
- Network/TLS/Core.hs +28/−24
- Network/TLS/Handshake/Client/ServerHello.hs +3/−0
- Network/TLS/Handshake/Client/TLS13.hs +1/−1
- Network/TLS/Handshake/Common.hs +7/−10
- Network/TLS/Handshake/Server.hs +3/−1
- Network/TLS/Handshake/Server/ClientHello13.hs +6/−3
- Network/TLS/Handshake/Server/ServerHello12.hs +5/−1
- Network/TLS/Handshake/Server/TLS13.hs +6/−0
- Network/TLS/Handshake/Signature.hs +10/−7
- Network/TLS/IO.hs +5/−13
- Network/TLS/IO/Decode.hs +9/−0
- Network/TLS/Internal.hs +2/−0
- Network/TLS/Parameters.hs +5/−5
- Network/TLS/Record/Decrypt.hs +51/−25
- Network/TLS/Record/Recv.hs +16/−1
- Network/TLS/Types/Session.hs +17/−0
- test/CiphersSpec.hs +12/−0
- test/HandshakeSpec.hs +336/−0
- tls.cabal +1/−1
CHANGELOG.md view
@@ -1,5 +1,20 @@ # Change log for "tls" +## Version 2.4.13++* Keep the CBC MAC check from timing the padding (Lucky Thirteen).+ [#598](https://github.com/haskell-tls/hs-tls/pull/598)+* Refuse a message after one that changes the keys in its record.+ [#610](https://github.com/haskell-tls/hs-tls/pull/610)+* Skip rejected early data by bytes, up to `max 16384 serverEarlyDataSize`, and only until a record decrypts.+ [#616](https://github.com/haskell-tls/hs-tls/pull/616)+* Offer only the signature algorithms that can be signed with.+ [#599](https://github.com/haskell-tls/hs-tls/pull/599)+* Refuse empty handshake records, and raise the default of `limitHandshakeFragment` to 2048.+ [#615](https://github.com/haskell-tls/hs-tls/pull/615)+* Add `defaultSessionData`.+ [#630](https://github.com/haskell-tls/hs-tls/pull/630)+ ## Version 2.4.12 * Authenticate a server that rejects the PSK of 0-RTT.
Network/TLS.hs view
@@ -167,6 +167,7 @@ -- ** Session data SessionData,+ defaultSessionData, sessionVersion, sessionCipher, sessionCompression,
Network/TLS/Context/Internal.hs view
@@ -29,6 +29,7 @@ contextModifyHooks, setEOF, setEstablished,+ skipEarlyData, contextFlush, contextClose, contextSend,@@ -282,7 +283,7 @@ data Established = NotEstablished | EarlyDataAllowed Int -- server: remaining 0-RTT bytes allowed- | EarlyDataNotAllowed Int -- sever: remaining 0-RTT packets allowed to skip+ | EarlyDataNotAllowed Int -- server: remaining 0-RTT bytes allowed to skip | EarlyDataSending | Established deriving (Eq, Show)@@ -387,6 +388,24 @@ setEstablished :: Context -> Established -> IO () setEstablished ctx = writeIORef (ctxEstablished_ ctx)++-- | Skips a record of rejected early data, given its length on the wire, if+-- the server is skipping them. Going over what may be skipped is refused+-- with unexpected_message (RFC 9846 Section 4.2.10).+skipEarlyData :: Context -> Int -> IO Bool+skipEarlyData ctx len = do+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed n+ | cost <= n -> do+ setEstablished ctx $ EarlyDataNotAllowed (n - cost)+ return True+ | otherwise ->+ throwCore $ Error_Protocol "too much early data to skip" UnexpectedMessage+ _ -> return False+ where+ -- The AEAD tag and the inner content type are not early data.+ cost = max 1 (len - 17) withLog :: Context -> (Logging -> IO ()) -> IO () withLog ctx f = ctxWithHooks ctx (f . hookLogging)
Network/TLS/Core.hs view
@@ -335,13 +335,6 @@ | otherwise -> let reason = "early data overflow" in terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvData13 ctx -- ignore "x"- | otherwise -> do- let reason = "early data deprotect overflow"- terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Established -> resetTLS13KeyUpdateCount ctx >> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do@@ -389,14 +382,17 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} 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+ aligned <- isAligned ctx hbs+ unless aligned $+ terminate13+ ctx+ (Error_Misc notAligned)+ AlertLevel_Fatal+ UnexpectedMessage+ notAligned established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal.@@ -440,7 +436,7 @@ let reason = "HRR is not allowed for 0-RTT" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return ()- cont <- popAction ctx hb+ cont <- popAction ctx hb hbs when cont $ loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO ()@@ -489,15 +485,15 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hbs loopHandshake13 (hb : hbs) = do- cont <- popAction ctx hb+ cont <- popAction ctx hb hbs when cont $ loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13R -> IO Bool-popAction ctx hb@(h, _b) = do+popAction :: Context -> Handshake13R -> [Handshake13R] -> IO Bool+popAction ctx hb@(h, _b) hbs = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of Nothing -> return False@@ -508,14 +504,14 @@ handleException ctx $ do case action of PendingRecvAction needAligned pa -> do- when needAligned $ checkAlignment ctx+ checkAligned needAligned updateTranscriptHash13 ctx hb pa h PendingRecvActionSelfUpdate needAligned pa -> do- when needAligned $ checkAlignment ctx+ checkAligned needAligned pa hb PendingRecvActionHash needAligned pa -> do- when needAligned $ checkAlignment ctx+ checkAligned needAligned d <- transcriptHash ctx "Pending action" updateTranscriptHash13 ctx hb pa d h@@ -525,13 +521,21 @@ -- the app data. sendCFifNecessary ctx return True+ where+ -- The write lock is held here, so 'handleException' sends the alert.+ checkAligned needAligned = when needAligned $ do+ aligned <- isAligned ctx hbs+ unless aligned $ throwCore $ Error_Protocol notAligned UnexpectedMessage -checkAlignment :: Context -> IO ()-checkAlignment ctx = do+-- RFC 9846 Section 5.1: a message before a key change must end its+-- record, so neither a message nor a fragment may follow it.+isAligned :: Context -> [Handshake13R] -> IO Bool+isAligned ctx hbs = do complete <- isRecvComplete ctx- unless complete $ do- let reason = "received message not aligned with record boundary"- terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ return $ complete && null hbs++notAligned :: String+notAligned = "received message not aligned with record boundary" -- the other side could have close the connection already, so wrap -- this in a try and ignore all exceptions
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -53,6 +53,9 @@ -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR+ -- In TLS 1.3, ServerHello must end its record (RFC 9846 Section 5.1).+ when (ver == TLS13 && not (null hbs)) $+ unexpected (show $ map fst hbs) Nothing return (ver, hbs, hrr) where recvSH = do
Network/TLS/Handshake/Client/TLS13.hs view
@@ -438,7 +438,7 @@ setPendingRecvActions ctx $ if resuming then- [ PendingRecvAction True (expectEncryptedExtensions ctx)+ [ PendingRecvAction False (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] else
Network/TLS/Handshake/Common.hs view
@@ -151,16 +151,13 @@ pkts <- recvPacket12 ctx case pkts of 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.- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- recvPacketHandshake ctx- _ -> unexpected (show x) (Just "handshake")+ Right x@(AppData bs) -> do+ -- A TLS 1.3 server that sent HelloRetryRequest skips early data+ -- until the second ClientHello (RFC 9846 Section 4.2.10).+ skipped <- skipEarlyData ctx (B.length bs)+ if skipped+ then recvPacketHandshake ctx+ else unexpected (show x) (Just "handshake") Right x -> unexpected (show x) (Just "handshake") Left err -> throwCore err
Network/TLS/Handshake/Server.hs view
@@ -35,7 +35,9 @@ handshakeServer sparams ctx = liftIO $ do hbs <- recvPacketHandshake ctx case hbs of- chb : _ -> handshake sparams ctx chb+ -- The keys may change after ClientHello (RFC 9846 Section 5.1)+ -- and nothing else is expected anyway.+ [chb] -> handshake sparams ctx chb _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") handshakeServerWith
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -61,9 +61,12 @@ (\(EarlyDataIndication _) -> True) if rtt0 then- -- mark a 0-RTT attempt before a possible HRR, and before updating the- -- status again if 0-RTT successful- setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding+ -- Skip up to this many bytes of rejected early data: a record's worth+ -- at least, even if early data is not accepted (0 by default), and+ -- more only if the server accepts more. Updated if 0-RTT succeeds.+ setEstablished+ ctx+ (EarlyDataNotAllowed (max 16384 (serverEarlyDataSize sparams))) else -- In the case of HRR, EarlyDataNotAllowed is already set. -- It should be cleared here.
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -196,7 +196,11 @@ -- not called. decideHashSig pubKey = do case filter (pubKey `signatureCompatible`) commonHashSigs of- [] -> error ("no hash signature for " ++ pubkeyType pubKey)+ [] ->+ throwCore $+ Error_Protocol+ ("no hash signature for " ++ pubkeyType pubKey)+ HandshakeFailure x : _ -> return x generateSKX_DHE kxsAlg = do
Network/TLS/Handshake/Server/TLS13.hs view
@@ -279,6 +279,12 @@ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref chk ((KeyUpdate13 mode, _) : hbs) = do+ complete <- isRecvComplete ctx+ unless (complete && null hbs) $+ terminate ctx $+ Error_Protocol+ "received message not aligned with record boundary"+ UnexpectedMessage case limitKeyUpdate $ sharedLimit $ ctxShared ctx of Just limit | limit > 0 -> do count <- incrementTLS13KeyUpdateCount ctx
Network/TLS/Handshake/Signature.hs view
@@ -66,13 +66,16 @@ signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384-signatureCompatible (PubKeyRSA pk) (_, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512-signatureCompatible (PubKeyDSA _) (_, SignatureDSA) = True-signatureCompatible (PubKeyEC _) (_, SignatureECDSA) = True-signatureCompatible (PubKeyEd25519 _) (_, SignatureEd25519) = True-signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True+-- Only what signatureParams implements: a combination it does not, such as+-- ecdsa_sha224, must not be chosen and then fail to sign.+signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256+signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384+signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512+signatureCompatible (PubKeyDSA _) (HashSHA1, SignatureDSA) = True+signatureCompatible (PubKeyEC _) (h, SignatureECDSA) =+ h `elem` [HashSHA1, HashSHA256, HashSHA384, HashSHA512]+signatureCompatible (PubKeyEd25519 _) (HashIntrinsic, SignatureEd25519) = True+signatureCompatible (PubKeyEd448 _) (HashIntrinsic, SignatureEd448) = True signatureCompatible _ (_, _) = False -- Whether the signature algorithm is for the type of the key, whatever
Network/TLS/IO.hs view
@@ -92,7 +92,7 @@ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx loop count | count > lim = do- let err = Error_Packet "too many handshake fragment"+ let err = tooManyFragments logPacket ctx $ show err return $ Left err loop count = do@@ -134,6 +134,9 @@ logPacket ctx $ show err return pktRecv +tooManyFragments :: TLSError+tooManyFragments = Error_Protocol "too many handshake fragments" UnexpectedMessage+ isCCS :: Record a -> Bool isCCS (Record ProtocolType_ChangeCipherSpec _ _) = True isCCS _ = False@@ -153,21 +156,10 @@ lim = limitHandshakeFragment $ sharedLimit $ ctxShared ctx loop count | count > lim =- return $ Left $ Error_Packet "too many handshake fragment"+ return $ Left tooManyFragments loop count = do erecord <- recordRecv13 recordLayer ctx case erecord of- Left err@(Error_Protocol _ BadRecordMac) -> do- -- If the server decides to reject RTT0 data but accepts RTT1- -- data, the server should skip all records for RTT0 data.- logPacket ctx $ show err- established <- ctxEstablished ctx- case established of- EarlyDataNotAllowed n- | n > 0 -> do- setEstablished ctx $ EarlyDataNotAllowed (n - 1)- loop (count + 1)- _ -> return $ Left err Left err -> do logPacket ctx $ show err return $ Left err
Network/TLS/IO/Decode.hs view
@@ -47,6 +47,10 @@ return $ Left $ Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake"+-- RFC 9846 Section 5.1: handshake records are never empty. The check+-- also keeps an empty one from ending the input of a partial message.+decodePacket12 _ (Record ProtocolType_Handshake _ fragment)+ | BS.null (fragmentGetBytes fragment) = return $ Left emptyHandshake decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do mhs <- getHState ctx let keyxchg = mhs >>= hstPendingCipher >>= Just . cipherKeyExchange@@ -94,6 +98,9 @@ return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty +emptyHandshake :: TLSError+emptyHandshake = Error_Protocol "empty handshake record" UnexpectedMessage+ ---------------------------------------------------------------- decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13)@@ -103,6 +110,8 @@ Right _ -> return $ Right ChangeCipherSpec13 decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment))+decodePacket13 _ (Record ProtocolType_Handshake _ fragment)+ | BS.null (fragmentGetBytes fragment) = return $ Left emptyHandshake decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do (mCont, wirebytes) <- gets stHandshakeRecordCont13 modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})
Network/TLS/Internal.hs view
@@ -14,6 +14,7 @@ sendPacket12, recvPacket12, makeCipherShowPretty,+ paddingIsValid, ) where import Data.IORef@@ -25,6 +26,7 @@ import Network.TLS.IO.Encode import Network.TLS.Packet import Network.TLS.Packet13+import Network.TLS.Record.Decrypt (paddingIsValid) import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types
Network/TLS/Parameters.hs view
@@ -883,11 +883,11 @@ -- -- Default: Nothing , limitHandshakeFragment :: Int- -- ^ The limit to accept the number of each handshake message.- -- For instance, a nasty client may send many fragments of client- -- certificate.+ -- ^ The number of records that may carry a handshake message before+ -- the one that completes it. A peer may split a message into records+ -- as small as one byte, and each is held until the message is complete. --- -- Default: 32+ -- Default: 2048 , limitKeyUpdate :: Maybe Int -- ^ Maximum number of consecutive TLS 1.3 KeyUpdate messages accepted -- without intervening non-empty application data. This bounds the CPU@@ -904,6 +904,6 @@ defaultLimit = Limit { limitRecordSize = Nothing- , limitHandshakeFragment = 32+ , limitHandshakeFragment = 2048 , limitKeyUpdate = Just 32 }
Network/TLS/Record/Decrypt.hs view
@@ -2,6 +2,7 @@ module Network.TLS.Record.Decrypt ( decryptRecord,+ paddingIsValid, ) where import Control.Monad.State.Strict@@ -67,10 +68,10 @@ -- | Check a decrypted record. ----- The first 'Bool' is what the lengths already said: 'False' when the padding--- length the record claims cannot be one. It is carried in rather than--- answered where it was found, so that the MAC is computed either way -- see--- 'decryptData'.+-- The first 'Bool' is what the lengths and the padding already said: 'False'+-- when the padding the record claims cannot be one or is not filled with its+-- length. It is carried in rather than answered where it was found, so that+-- the MAC is computed either way -- see 'decryptData'. -- -- Everything is computed before anything is decided, and the verdicts are -- combined with '&&!', which does not short-circuit.@@ -87,18 +88,7 @@ -- measurement of how much of the MAC was guessed correctly. return (expected_digest `BA.constEq` digest) - -- check if the padding is filled with the correct pattern if it exists- -- (before TLS10 this checks instead that the padding length is minimal)- paddingValid <- case cipherDataPadding cdata of- Nothing -> return True- Just (pad, _blksz) -> do- let b = fromIntegral (B.length pad - 1)- -- Every octet, and no allocation of a pattern to compare against:- -- B.all stops at the first wrong octet, and replicating the- -- pattern costs time in proportion to a length the peer chose.- return $ B.foldl' (\acc w -> acc .|. (w `xor` b)) 0 pad == 0-- unless (lengthValid &&! macValid &&! paddingValid) $+ unless (lengthValid &&! macValid) $ throwError $ Error_Protocol "bad record mac Stream/Block" BadRecordMac @@ -174,15 +164,19 @@ lengthValid = claimed + macSize <= plainlen paddinglength = if lengthValid then claimed else 1 contentlen = plainlen - paddinglength - macSize- (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)- getCipherData- record- lengthValid- CipherData- { cipherDataContent = content- , cipherDataMAC = Just mac- , cipherDataPadding = Just (padding, blockSize)- }+ paddingValid = paddingIsValid content' paddinglength+ -- Lucky Thirteen: the rounds a longer padding saves on the MAC.+ dummy = hmacDummyRounds (cipherHash cipher) contentlen (plainlen - 1 - macSize)+ (content, mac, _) <- get3i content' (contentlen, macSize, paddinglength)+ dummy `seq`+ getCipherData+ record+ (lengthValid &&! paddingValid)+ CipherData+ { cipherDataContent = content+ , cipherDataMAC = Just mac+ , cipherDataPadding = Nothing+ } decryptOf (BulkStateStream (BulkStream decryptF)) = do -- check if we have enough bytes to cover the minimum for this cipher when (econtentLen < macSize) sanityCheckError@@ -247,3 +241,35 @@ maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $ partition3 s ls get2i s (d1, d2) = get3i s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)++-- | Whether the last @padLen@ octets of the plaintext all equal its last+-- octet. All 256 octets a padding can span are read, whatever @padLen@.+paddingIsValid :: ByteString -> Int -> Bool+paddingIsValid plain padLen = go 0 0 == 0+ where+ window = B.drop (B.length plain - 256) plain+ wlen = B.length window+ b = B.last plain+ go :: Int -> Word8 -> Word8+ go i acc+ | i == wlen = acc+ | otherwise =+ go (i + 1) $ acc .|. (inPadding i .&. (B.index window (wlen - 1 - i) `xor` b))+ -- 0xff for an octet less than padLen from the end, without a branch+ inPadding i = fromIntegral ((i - padLen) `shiftR` (finiteBitSize i - 1))++-- | HMAC over a shorter content takes fewer compression rounds of the hash.+-- Spend the difference from the longest content on dummy blocks, so that a+-- record takes as long whatever its padding says.+hmacDummyRounds :: Hash -> Int -> Int -> ByteString+hmacDummyRounds h contentLen maxContentLen =+ hash h $ B.take ((rounds maxContentLen - rounds contentLen) * bs) dummyBlocks+ where+ bs = hashBlockSize h+ -- the ipad block, the sequence number and header, the content, and the+ -- 0x80 octet and length field of the hash padding+ rounds n = (bs + 13 + n + 1 + lengthField + bs - 1) `div` bs+ lengthField = if bs == 128 then 16 else 8++dummyBlocks :: ByteString+dummyBlocks = B.replicate (8 * 128) 0
Network/TLS/Record/Recv.hs view
@@ -89,7 +89,22 @@ then return $ Left maximumSizeExceeded else readExactBytes ctx (fromIntegral readlen)- >>= either (return . Left) (getRecord ctx header)+ >>= either (return . Left) (getRecord13 header)+ -- RFC 9846 Section 4.2.10: a server that rejected early data skips the+ -- records it cannot deprotect, until the first one it can.+ getRecord13 header@(Header ty _ readlen) content = do+ erecord <- getRecord ctx header content+ case erecord of+ Left (Error_Protocol _ BadRecordMac) -> do+ skipped <- skipEarlyData ctx (fromIntegral readlen)+ if skipped then recvRecord13 ctx else return erecord+ Right _ | ty == ProtocolType_AppData -> do+ established <- ctxEstablished ctx+ case established of+ EarlyDataNotAllowed _ -> setEstablished ctx NotEstablished+ _ -> return ()+ return erecord+ _ -> return erecord maximumSizeExceeded :: TLSError maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow
Network/TLS/Types/Session.hs view
@@ -84,6 +84,23 @@ . shows (sessionFlags sd) . showChar '}' +-- | A 'SessionData' to build one from with record update syntax, so that a+-- field added later does not break the code that builds it.+defaultSessionData :: SessionData+defaultSessionData =+ SessionData+ { sessionVersion = TLS13+ , sessionCipher = 0+ , sessionCompression = 0+ , sessionClientSNI = Nothing+ , sessionSecret = B.empty+ , sessionGroup = Nothing+ , sessionTicketInfo = Nothing+ , sessionALPN = Nothing+ , sessionMaxEarlyDataSize = 0+ , sessionFlags = []+ }+ is0RTTPossible :: SessionData -> Bool is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0
test/CiphersSpec.hs view
@@ -5,6 +5,7 @@ import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Extra.Cipher+import Network.TLS.Internal (paddingIsValid) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck@@ -20,6 +21,17 @@ (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF iv t additional (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF t _ -> return ()+ describe "CBC padding" $ do+ -- Read in constant time; the answer is still the plain one.+ prop "is valid when the last octets equal the last" $ \(NonEmpty ws) (Positive n) -> do+ let plain = B.pack ws+ padLen = 1 + (n - 1) `mod` min 256 (B.length plain)+ expected = B.all (== B.last plain) $ B.drop (B.length plain - padLen) plain+ paddingIsValid plain padLen `shouldBe` expected+ prop "accepts a padding filled with its length" $ \ws (Positive n) -> do+ let len = (n - 1) `mod` 256+ plain = B.pack ws <> B.replicate (len + 1) (fromIntegral len)+ paddingIsValid plain (len + 1) `shouldBe` True block :: BulkBlock
test/HandshakeSpec.hs view
@@ -128,6 +128,8 @@ handshake12_server_key_xchg_sigalg (HashIntrinsic, SignatureRSApsspssSHA256) rejectedAsDecryptError+ it "refuses a TLS 1.2 signature algorithm it cannot sign with" $+ handshake12_unimplemented_sigalg prop "can receive client authentication failure" handshake_client_auth_fail it "accepts an empty TLS 1.2 client certificate when the hook does" $ handshake_client_auth_empty TLS12@@ -191,6 +193,12 @@ handshake13_0rtt_psk_rejected False it "authenticates a server rejecting the PSK of 0RTT, asking a cert" $ handshake13_0rtt_psk_rejected True+ it "skips rejected early data in many records" $+ handshake13_0rtt_skip (replicate 5 100) True+ it "skips rejected early data beyond serverEarlyDataSize" $+ handshake13_0rtt_skip [10000] True+ it "refuses rejected early data over a record's worth" $+ handshake13_0rtt_skip [16384, 4000] False prop "can handshake with TLS 1.3 EE" handshake13_ee_groups prop "can handshake with TLS 1.3 EC groups" handshake13_ec prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe@@ -248,6 +256,24 @@ server_first_record_type_unexpected 24 0 it "rejects application data inside a TLS 1.3 handshake message" $ handshake13_interleaved_app_data+ it "rejects an empty handshake record before a ClientHello" $+ handshake_empty_handshake_record True+ it "rejects an empty handshake record inside a ClientHello" $+ handshake_empty_handshake_record False+ it "accepts a TLS 1.2 ClientHello in one-byte records" $+ handshake_one_byte_records TLS12 Nothing+ it "accepts a TLS 1.3 ClientHello in one-byte records" $+ handshake_one_byte_records TLS13 Nothing+ it "rejects a ClientHello in more records than the limit" $+ handshake_one_byte_records TLS13 (Just 8)+ it "rejects a message after ClientHello in its record" $+ handshake13_trailing_after_hello True+ it "rejects a message after ServerHello in its record" $+ handshake13_trailing_after_hello False+ it "rejects a message after ServerHello in its record with 0-RTT" $+ handshake13_0rtt_trailing_after_server_hello+ it "rejects a message after KeyUpdate in its record" $+ handshake13_trailing_after_key_update it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $ malformed_ccs_unexpected TLS12@@ -1117,6 +1143,39 @@ (handshake cctx `shouldThrow` rejected) r `shouldSatisfy` isJust +-- ecdsa_sha224 is a combination TLS 1.2 allows and this library does not+-- implement. Configured on both sides, it must not be chosen and then fail+-- to sign with an ErrorCall; the handshake fails with an alert instead.+handshake12_unimplemented_sigalg :: IO ()+handshake12_unimplemented_sigalg = do+ let cipher = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256+ sha224 = defaultSupported{supportedHashSignatures = [(HashSHA224, SignatureECDSA)]}+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS12], [TLS12])+ ([cipher], [cipher])+ creds <- generate arbitraryCredentialsOfEachType+ let cred = head [c | c@(_, PrivKeyEC _) <- creds]+ clientParam' =+ clientParam+ { clientSupported =+ sha224{supportedCiphers = [cipher], supportedVersions = [TLS12]}+ }+ serverParam' =+ serverParam+ { serverSupported =+ sha224{supportedCiphers = [cipher], supportedVersions = [TLS12]}+ , serverShared =+ (serverShared serverParam){sharedCredentials = Credentials [cred]}+ }+ r <- timeout 10000000 $+ withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` rejectedAsHandshakeFailure)+ (void (E.try (handshake cctx) :: IO (Either TLSException ())))+ r `shouldSatisfy` isJust+ -- A DER ECDSA signature that does not decode is a signature that does not -- verify, a decrypt_error. The client's TLS 1.3 CertificateVerify -- signature is replaced on its way to the server with one that the ASN.1@@ -2327,6 +2386,58 @@ } runTLS0RTT (pc{clientUseEarlyData = True}, ps') FullHandshake earlyData +-- RFC 9846 Section 4.2.10: a server that has forgotten the session skips+-- the early data, sent in records of the given lengths, up to a record's+-- worth since it accepts no early data itself.+handshake13_0rtt_skip :: [Int] -> Bool -> IO ()+handshake13_0rtt_skip lens ok = do+ (cli, srv) <- generate arbitraryPairParams13+ let params0 = fixGroupsX25519 (cli, srv{serverEarlyDataSize = 65536})+ sessionRefs <- twoSessionRefs+ let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0+ runTLSSimple13 params FullHandshake+ Just sessionParams <- readClientSessionRef sessionRefs+ writeIORef (snd sessionRefs) Nothing+ let (pc, ps) = setPairParamsSessionResuming sessionParams params+ chunks = [B.replicate n 0x61 | n <- lens]+ len = sum lens+ r <- timeout 10000000 $+ withPairContext (pc{clientUseEarlyData = True}, ps{serverEarlyDataSize = 0}) $+ \(cctx, sctx) ->+ if ok+ then+ concurrently_+ ( do+ handshake sctx+ recvAll sctx len `shouldReturn` B.concat chunks+ sendData sctx "ok"+ )+ ( do+ handshake cctx+ mapM_ (sendData cctx . L.fromStrict) chunks+ recvData cctx `shouldReturn` "ok"+ )+ else+ concurrently_+ ((handshake sctx >> recvData sctx) `shouldThrow` tooMuch)+ ( void+ ( E.try+ (handshake cctx >> mapM_ (sendData cctx . L.fromStrict) chunks >> recvData cctx)+ :: IO (Either TLSException B.ByteString)+ )+ )+ r `shouldSatisfy` isJust+ where+ recvAll ctx n+ | n <= 0 = return ""+ | otherwise = do+ bs <- recvData ctx+ when (B.null bs) $ fail "EOF"+ (bs <>) <$> recvAll ctx (n - B.length bs)+ tooMuch (HandshakeFailed (Error_Protocol msg UnexpectedMessage)) = "too much" `isInfixOf` msg+ tooMuch (Terminated _ _ (Error_Protocol msg UnexpectedMessage)) = "too much" `isInfixOf` msg+ tooMuch _ = False+ handshake13_ee_groups :: CSP13 -> IO () handshake13_ee_groups (CSP13 (cli, srv)) = do let -- The client prefers P256@@ -2759,6 +2870,225 @@ unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest) unhex _ = error "unhex" +-- RFC 9846 Section 5.1: the messages before a key change must end their+-- record. The record holding the ClientHello (the client's first) gets a+-- copy of it, or that holding the ServerHello (the server's first) gets a+-- Finished-shaped message.+handshake13_trailing_after_hello :: Bool -> IO ()+handshake13_trailing_after_hello afterCH = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ let params = fixGroupsX25519 (clientParam, serverParam)+ ref <- newIORef False+ let wraps+ | afterCH = (appendToFirstRecord ref id, id)+ | otherwise = (id, appendToFirstRecord ref (const trailingFinished))+ r <- timeout 10000000 $+ withPairContextWith wraps params $ \(cctx, sctx) ->+ if afterCH+ then+ concurrently_+ (handshake sctx `shouldThrow` rejectedAsUnexpected)+ (void (E.try (handshake cctx) :: IO (Either TLSException ())))+ else+ concurrently_+ ( void+ (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString))+ )+ (handshake cctx `shouldThrow` rejectedAsUnexpected)+ r `shouldSatisfy` isJust+ readIORef ref `shouldReturn` True++-- As above, for the plaintext ServerHello that the client takes in its+-- receive loop after sending early data.+handshake13_0rtt_trailing_after_server_hello :: IO ()+handshake13_0rtt_trailing_after_server_hello = do+ (cli, srv) <- generate arbitraryPairParams13+ let params0 = fixGroupsX25519 (cli, srv{serverEarlyDataSize = 2048})+ sessionRefs <- twoSessionRefs+ let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0+ runTLSSimple13 params FullHandshake+ Just sessionParams <- readClientSessionRef sessionRefs+ let (pc, ps) = setPairParamsSessionResuming sessionParams params+ ref <- newIORef False+ r <- timeout 10000000+ $ withPairContextWith+ (id, appendToFirstRecord ref (const trailingFinished))+ (pc{clientUseEarlyData = True}, ps)+ $ \(cctx, sctx) ->+ concurrently_+ ( void+ (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString))+ )+ ( do+ handshake cctx+ sendData cctx "early"+ recvData cctx `shouldThrow` notAligned+ )+ r `shouldSatisfy` isJust+ readIORef ref `shouldReturn` True+ where+ notAligned (HandshakeFailed (Error_Protocol msg UnexpectedMessage)) =+ "not aligned" `isInfixOf` msg+ notAligned _ = False++-- After the handshake the client sends, protected under its application+-- traffic secret, a record holding a KeyUpdate and a Finished-shaped message,+-- and then application data under the same secret.+handshake13_trailing_after_key_update :: IO ()+handshake13_trailing_after_key_update = do+ let cipher = cipher13_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS13], [TLS13])+ ([cipher], [cipher])+ secretRef <- newIORef Nothing+ sendRef <- newIORef (\_ -> return ())+ let logKey line = case words line of+ ["CLIENT_TRAFFIC_SECRET_0", _, h] -> writeIORef secretRef (Just h)+ _ -> return ()+ clientParam' =+ clientParam+ { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey}+ }+ capture be =+ be+ { backendSend = \bs -> do+ writeIORef sendRef (backendSend be)+ backendSend be bs+ }+ r <- timeout 10000000 $+ withPairContextWith (capture, id) (clientParam', serverParam) $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx >> (recvData sctx `shouldThrow` anyTLSException))+ ( do+ handshake cctx+ Just h <- readIORef secretRef+ send <- readIORef sendRef+ let secret = BA.convert (unhexBytes h) :: BA.ScrubbedBytes+ key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString+ iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString+ keyUpdate = B.pack [24, 0, 0, 1, 0]+ send $ protect13 key iv 0 22 (keyUpdate <> trailingFinished)+ send $ protect13 key iv 1 23 "hello"+ recvData cctx `shouldThrow` peerSentUnexpected+ )+ r `shouldSatisfy` isJust++unhexBytes :: String -> B.ByteString+unhexBytes [] = B.empty+unhexBytes (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhexBytes rest)+unhexBytes _ = error "unhexBytes"++-- A Finished message with a zero verify_data of SHA-256 size.+trailingFinished :: B.ByteString+trailingFinished = B.pack (20 : 0 : 0 : 32 : replicate 32 0)++-- Groups fixed so that no HelloRetryRequest happens.+fixGroupsX25519 :: (ClientParams, ServerParams) -> (ClientParams, ServerParams)+fixGroupsX25519 (cli, srv) =+ ( cli{clientSupported = (clientSupported cli){supportedGroups = [X25519]}}+ , srv+ { serverSupported =+ (serverSupported srv)+ { supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ }+ )++-- RFC 9846 Section 5.1: handshake records are never empty. The client's+-- ClientHello record gets an empty one before it or in the middle of it.+handshake_empty_handshake_record :: Bool -> IO ()+handshake_empty_handshake_record before = do+ (clientParam, serverParam) <- generate arbitrary+ ref <- newIORef False+ let split body+ | before = ["", body]+ | otherwise = [B.take 10 body, "", B.drop 10 body]+ r <- timeout 10000000 $+ withPairContextWith (splitFirstRecord ref split, id) (clientParam, serverParam) $+ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "empty")+ (handshake cctx `shouldThrow` anyTLSException)+ r `shouldSatisfy` isJust+ readIORef ref `shouldReturn` True++-- RFC 9846 Section 5.1 lets a handshake message be split into records of+-- any non-zero size. The ClientHello is sent a byte a record, which the+-- default limit of 2048 records accepts and the given limit refuses.+handshake_one_byte_records :: Version -> Maybe Int -> IO ()+handshake_one_byte_records ver mlim = do+ (clientParam, serverParam) <-+ fixGroupsX25519+ <$> generate+ (arbitraryPairParamsWithVersionsAndCiphers ([ver], [ver]) (ciphers, ciphers))+ let serverParam' = case mlim of+ Nothing -> serverParam+ Just lim ->+ let shared = serverShared serverParam+ in serverParam+ { serverShared =+ shared{sharedLimit = (sharedLimit shared){limitHandshakeFragment = lim}}+ }+ ref <- newIORef False+ let split = map B.singleton . B.unpack+ r <- timeout 10000000 $+ withPairContextWith (splitFirstRecord ref split, id) (clientParam, serverParam') $+ \(cctx, sctx) -> case mlim of+ Nothing -> concurrently_ (handshake sctx) (handshake cctx)+ Just _ ->+ concurrently_+ (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "too many")+ (handshake cctx `shouldThrow` anyTLSException)+ r `shouldSatisfy` isJust+ readIORef ref `shouldReturn` True+ where+ ciphers+ | ver == TLS13 = [cipher13_AES_128_GCM_SHA256]+ | otherwise = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256]++-- Sends the body of the first record, which is expected to be a plaintext+-- handshake record, in the records the function splits it into.+splitFirstRecord+ :: IORef Bool -> (B.ByteString -> [B.ByteString]) -> Backend -> Backend+splitFirstRecord ref split be =+ be+ { backendSend = \bs -> do+ done <- readIORef ref+ if done || B.take 1 bs /= B.singleton 22+ then backendSend be bs+ else do+ writeIORef ref True+ let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4)+ (body, rest) = B.splitAt len $ B.drop 5 bs+ record b = B.take 3 bs <> encodeWord16 (fromIntegral $ B.length b) <> b+ backendSend be $ B.concat (map record (split body)) <> rest+ }++-- Puts bytes made from its body at the end of the first record sent, which+-- is expected to be a plaintext handshake record.+appendToFirstRecord+ :: IORef Bool -> (B.ByteString -> B.ByteString) -> Backend -> Backend+appendToFirstRecord ref mkExtra be =+ be+ { backendSend = \bs -> do+ done <- readIORef ref+ if done || B.take 1 bs /= B.singleton 22+ then backendSend be bs+ else do+ writeIORef ref True+ let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4)+ (body, rest) = B.splitAt len $ B.drop 5 bs+ extra = mkExtra body+ len' = len + B.length extra+ hdr =+ B.take 3 bs+ <> B.pack [fromIntegral (len' `div` 256), fromIntegral (len' `mod` 256)]+ backendSend be $ hdr <> body <> extra <> rest+ }+ -- A ChangeCipherSpec is the single byte 1; any other value is answered with -- unexpected_message (RFC 8446 Section 5), and so is one carrying two of -- them. The client's ChangeCipherSpec record is made two bytes long. The@@ -2807,6 +3137,12 @@ ) r `shouldSatisfy` isJust readIORef seen `shouldReturn` True++-- Refused with the alert, for a reason containing the string.+refusedFor :: AlertDescription -> String -> TLSException -> Bool+refusedFor ad needle (HandshakeFailed (Error_Protocol reason ad')) =+ ad == ad' && needle `isInfixOf` reason+refusedFor _ _ _ = False rejectedAsUnexpected :: TLSException -> Bool rejectedAsUnexpected (HandshakeFailed (Error_Packet_unexpected _ _)) = True
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls-version: 2.4.12+version: 2.4.13 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>