diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -167,6 +167,7 @@ -- ** Session data SessionData, + defaultSessionData, sessionVersion, sessionCipher, sessionCompression, diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -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) diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -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 diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -438,7 +438,7 @@ setPendingRecvActions ctx $ if resuming then - [ PendingRecvAction True (expectEncryptedExtensions ctx) + [ PendingRecvAction False (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] else diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -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 diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -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. diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -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 diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -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 diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -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 diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -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 diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs --- a/Network/TLS/IO/Decode.hs +++ b/Network/TLS/IO/Decode.hs @@ -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, [])}) diff --git a/Network/TLS/Internal.hs b/Network/TLS/Internal.hs --- a/Network/TLS/Internal.hs +++ b/Network/TLS/Internal.hs @@ -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 diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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 } diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs --- a/Network/TLS/Record/Decrypt.hs +++ b/Network/TLS/Record/Decrypt.hs @@ -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 diff --git a/Network/TLS/Record/Recv.hs b/Network/TLS/Record/Recv.hs --- a/Network/TLS/Record/Recv.hs +++ b/Network/TLS/Record/Recv.hs @@ -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 diff --git a/Network/TLS/Types/Session.hs b/Network/TLS/Types/Session.hs --- a/Network/TLS/Types/Session.hs +++ b/Network/TLS/Types/Session.hs @@ -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 diff --git a/test/CiphersSpec.hs b/test/CiphersSpec.hs --- a/test/CiphersSpec.hs +++ b/test/CiphersSpec.hs @@ -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 diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -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 diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -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