tls 2.4.14 → 2.5.0

raw patch · 42 files changed

+1998/−632 lines, 42 filesdep ~ech-configPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ech-config

API changes (from Hackage documentation)

Files

• CHANGELOG.md +59/−18
• Network/TLS.hs +21/−15
• Network/TLS/Context.hs +35/−12
• Network/TLS/Context/Internal.hs +39/−3
• Network/TLS/Core.hs +68/−23
• Network/TLS/Credentials.hs +36/−17
• Network/TLS/Extension.hs +9/−9
• Network/TLS/Handshake/Certificate.hs +28/−4
• Network/TLS/Handshake/Client/Common.hs +8/−7
• Network/TLS/Handshake/Client/TLS12.hs +13/−0
• Network/TLS/Handshake/Client/TLS13.hs +2/−2
• Network/TLS/Handshake/Common.hs +25/−0
• Network/TLS/Handshake/Common13.hs +17/−26
• Network/TLS/Handshake/Key.hs +3/−0
• Network/TLS/Handshake/Server.hs +1/−0
• Network/TLS/Handshake/Server/ClientHello12.hs +1/−1
• Network/TLS/Handshake/Server/ClientHello13.hs +4/−2
• Network/TLS/Handshake/Server/Common.hs +20/−9
• Network/TLS/Handshake/Server/ServerHello12.hs +1/−0
• Network/TLS/Handshake/Server/ServerHello13.hs +3/−3
• Network/TLS/Handshake/Server/TLS13.hs +113/−49
• Network/TLS/Handshake/Signature.hs +97/−95
• Network/TLS/Handshake/State.hs +15/−4
• Network/TLS/Handshake/State13.hs +7/−0
• Network/TLS/HashAndSignature.hs +0/−238
• Network/TLS/Packet.hs +15/−20
• Network/TLS/Packet13.hs +2/−2
• Network/TLS/Parameters.hs +83/−23
• Network/TLS/PostHandshake.hs +22/−1
• Network/TLS/Session.hs +1/−0
• Network/TLS/SignatureScheme.hs +304/−0
• Network/TLS/Struct.hs +4/−4
• Network/TLS/Types/Secret.hs +11/−0
• Network/TLS/Types/Session.hs +10/−1
• test/Arbitrary.hs +1/−1
• test/ChannelBindingSpec.hs +297/−0
• test/EncodeSpec.hs +1/−1
• test/HandshakeSpec.hs +575/−26
• test/Run.hs +2/−2
• test/SecretSpec.hs +1/−0
• tls.cabal +4/−3
• util/Server.hs +40/−11

@@ -1,19 +1,67 @@ # Change log for "tls" -## Version 2.4.14+## Version 2.5.0 -* Require hpke 0.4.+**The `tls-exporter` and `tls-server-end-point` channel bindings were+computed wrongly and now follow RFC 9266 and RFC 5929.**  No type changes, so+a downstream build stays green, but `getTLSExporter` and+`getTLSServerEndPoint` return different bytes than they did: two peers that+compare channel bindings have to be upgraded together.  `getTLSServerEndPoint`+also returns `Nothing` for an Ed25519 or Ed448 certificate now, whose+signature names no hash for the binding to use, where before it returned a+value computed under the negotiated cipher's hash.++* Derive `tls-exporter` over the hash of the empty transcript, and+  `tls-server-end-point` from the leaf certificate's own DER under its own+  signature hash.+  [#535](https://github.com/haskell-tls/hs-tls/pull/535)+* Write the exporter secret to the key log as `EXPORTER_SECRET`.+  [#535](https://github.com/haskell-tls/hs-tls/pull/535)+* `tls-simpleserver` reports the channel bindings with `--verbose`.+  [#535](https://github.com/haskell-tls/hs-tls/pull/535) * Bind the PSK to the transcript after HelloRetryRequest.-  This breaks a PSK after HRR with hs-tls 2.4.13 or earlier.+  This breaks a PSK after HRR with hs-tls 2.4 or earlier.   [#597](https://github.com/haskell-tls/hs-tls/pull/597)+* Keep the CBC MAC check from timing the padding (Lucky Thirteen).+  [#598](https://github.com/haskell-tls/hs-tls/pull/598)+* Offer only the signature algorithms that can be signed with.+  [#599](https://github.com/haskell-tls/hs-tls/pull/599)+* Carry a signature scheme as one number, `SignatureScheme`, with a pattern+  synonym for each IANA name.  `HashAlgorithm`, `SignatureAlgorithm` and+  `showSignatureScheme` are removed; `HashAndSignatureAlgorithm` remains as a+  deprecated synonym.+  [#588](https://github.com/haskell-tls/hs-tls/pull/588)+* Export `signatureSchemesForTLS13`.+  [#588](https://github.com/haskell-tls/hs-tls/pull/588) * Let application data and HelloRequest come during a TLS 1.2 handshake.   [#601](https://github.com/haskell-tls/hs-tls/pull/601)+* Report the signature schemes of the handshake in `Information`.+  [#603](https://github.com/haskell-tls/hs-tls/pull/603)+* Let a server choose ciphers in the client's order (`supportedClientCipherOrder`).+  [#605](https://github.com/haskell-tls/hs-tls/pull/605) * Tell why a certificate is rejected, and give the chain to `debugError` in PEM.   [#606](https://github.com/haskell-tls/hs-tls/pull/606)+* Tell the client certificate on resumption, kept in `SessionData`.+  Sessions saved by an earlier version cannot be resumed.+  [#607](https://github.com/haskell-tls/hs-tls/pull/607)+* Add `defaultSessionData`.+  [#607](https://github.com/haskell-tls/hs-tls/pull/607)+* Refuse a message after one that changes the keys in its record.+  [#610](https://github.com/haskell-tls/hs-tls/pull/610)+* Update the keys before the key usage limit (`limitRecordsPerKey`), and keep+  the number of updates under 2^48-1.+  [#611](https://github.com/haskell-tls/hs-tls/pull/611) * Give each PSK identity its own binder, and accept HelloRetryRequest with only a cookie.   [#612](https://github.com/haskell-tls/hs-tls/pull/612)+* Refuse an RSA key shorter than `supportedMinRSAKeySize` in the peer's certificate.+  This refuses 1024-bit RSA certificates by default.+  [#608](https://github.com/haskell-tls/hs-tls/pull/608) * Check the versions and extensions of the hello messages as RFC 9846 does.   [#614](https://github.com/haskell-tls/hs-tls/pull/614)+* Refuse empty handshake records, and raise the default of `limitHandshakeFragment` to 2048.+  [#615](https://github.com/haskell-tls/hs-tls/pull/615)+* 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) * Answer a certificate that is not DER with bad_certificate instead of decode_error.   [#617](https://github.com/haskell-tls/hs-tls/pull/617) * Answer an empty certificate with decode_error.@@ -32,25 +80,18 @@   [#624](https://github.com/haskell-tls/hs-tls/pull/624) * Answer several KeyUpdates with update_requested with a single KeyUpdate.   [#631](https://github.com/haskell-tls/hs-tls/pull/631)+* Refuse an RSA key in the peer's certificate longer than `supportedMaxRSAKeySize` (8192 by default), and a DH prime from a TLS 1.2 server outside `supportedMinDHKeySize` and `supportedMaxDHKeySize` (2048 and 8192 by default).+  This refuses 1024-bit custom DH parameters by default.+  [#632](https://github.com/haskell-tls/hs-tls/pull/632) * Add `closeNotifyReceived` to tell close_notify from an EOF without it.   [#635](https://github.com/haskell-tls/hs-tls/pull/635) * Resume a session only with its SNI on the client.   [#636](https://github.com/haskell-tls/hs-tls/pull/636)--## 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)+* Let a server choose the purposes accepted in a client certificate (`supportedClientCertificatePurposes`).+  [#638](https://github.com/haskell-tls/hs-tls/pull/638)+* Add `requestCertificateAsync`, whose response `recvData` processes, and deprecate `requestCertificate`.+  [#633](https://github.com/haskell-tls/hs-tls/pull/633)+* Require hpke 0.4.  ## Version 2.4.12 

@@ -115,6 +115,12 @@     defaultSupported,     supportedVersions,     supportedCiphers,+    supportedMinRSAKeySize,+    supportedMaxRSAKeySize,+    supportedClientCertificatePurposes,+    supportedMinDHKeySize,+    supportedMaxDHKeySize,+    supportedClientCipherOrder,     supportedCompressions,     supportedHashSignatures,     supportedSecureRenegotiation,@@ -143,6 +149,7 @@     limitHandshakeFragment,     limitKeyUpdate,     limitRecordSize,+    limitRecordsPerKey,      -- * Shared parameters @@ -179,6 +186,7 @@     sessionALPN,     sessionMaxEarlyDataSize,     sessionFlags,+    sessionClientCertificate,     SessionFlag (..),     TLS13TicketInfo,     is0RTTPossible,@@ -197,13 +205,10 @@     Version (..),     Compression (..),     nullCompression,+    SignatureScheme (..),     HashAndSignatureAlgorithm,     supportedSignatureSchemes,-    HashAlgorithm (..),-    SignatureAlgorithm (..),-    pattern MLDSA44,-    pattern MLDSA65,-    pattern MLDSA87,+    signatureSchemesForTLS13,     Group (..),     supportedNamedGroups,     EMSMode (..),@@ -241,6 +246,8 @@     infoTLS13HandshakeMode,     infoIsEarlyDataAccepted,     infoIsECHAccepted,+    infoServerSignatureScheme,+    infoClientSignatureScheme,     ClientRandom,     ServerRandom,     unClientRandom,@@ -257,6 +264,8 @@     updateKey,     KeyUpdateRequest (..),     requestCertificate,+    requestCertificateAsync,+    PHAResult (..),     getTLSUnique,     getTLSExporter,     getTLSServerEndPoint,@@ -305,6 +314,7 @@     -- ** Crypto Key     PubKey (..),     PrivKey (..),+    ExtKeyUsagePurpose (..),      -- ** Ciphers & Predefined ciphers     module Network.TLS.Cipher,@@ -317,7 +327,7 @@     clientUseMaxFragmentLength, ) where -import Data.X509 (PrivKey (..), PubKey (..))+import Data.X509 (ExtKeyUsagePurpose (..), PrivKey (..), PubKey (..)) import Data.X509.Validation hiding (HostName, defaultHooks)  import Network.TLS.Backend (Backend (..), HasBackend (..))@@ -349,18 +359,15 @@     CertificateType (..),     ClientRandom (..),     Handshake,-    HashAlgorithm (..),+    SignatureScheme (..),     HashAndSignatureAlgorithm,     Header (..),     ProtocolType (..),     ServerRandom (..),-    SignatureAlgorithm (..),     TLSError (..),     TLSException (..),+    signatureSchemesForTLS13,     supportedSignatureSchemes,-    pattern MLDSA44,-    pattern MLDSA65,-    pattern MLDSA87,  ) import Network.TLS.Struct13 (Handshake13) import Network.TLS.Types@@ -370,10 +377,9 @@ type Bytes = ByteString  -- | Getting certificates from a client, if any.---   Note that the certificates are not sent by a client---   on resumption even if client authentication is required.---   So, this API would be replaced by the one which can treat---   both cases of full-negotiation and resumption.+--   A client sends no certificate on resumption; then this returns the+--   leaf certificate it was authenticated with in the original connection.+--   That chain was validated then and is not checked again. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain 

@@ -76,6 +76,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict import Data.IORef+import qualified Data.X509 as X509  import Network.TLS.Backend import Network.TLS.Cipher@@ -87,15 +88,14 @@     handshakeServer,     handshakeServerWith,  )-import Network.TLS.Handshake.State13 import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.Measurement-import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.PostHandshake (     postHandshakeAuthClientWith,+    requestCertificateAsyncServer,     requestCertificateServer,  ) import Network.TLS.RNG@@ -118,6 +118,7 @@     doHandshake :: a -> Context -> IO ()     doHandshakeWith :: a -> Context -> HandshakeR -> IO ()     doRequestCertificate :: a -> Context -> IO Bool+    doRequestCertificateAsync :: a -> Context -> IO (Bool -> IO PHAResult)     doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO ()  instance TLSParams ClientParams where@@ -130,6 +131,7 @@     doHandshake = handshakeClient     doHandshakeWith = handshakeClientWith     doRequestCertificate _ _ = return False+    doRequestCertificateAsync _ _ = return $ \_ -> return PHAUnavailable     doPostHandshakeAuthWith = postHandshakeAuthClientWith  instance TLSParams ServerParams where@@ -142,6 +144,7 @@     doHandshake = handshakeServer     doHandshakeWith = handshakeServerWith     doRequestCertificate = requestCertificateServer+    doRequestCertificateAsync = requestCertificateAsyncServer     doPostHandshakeAuthWith = \_ _ _ -> return ()  -- | create a new context using the backend and parameters specified.@@ -191,6 +194,7 @@                 { doHandshake_ = doHandshake params                 , doHandshakeWith_ = doHandshakeWith params                 , doRequestCertificate_ = doRequestCertificate params+                , doRequestCertificateAsync_ = doRequestCertificateAsync params                 , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params                 } @@ -302,22 +306,41 @@     return $ case (msecret, mcipher) of         (Just secret, Just cipher) ->             let h = cipherHash cipher-                secret' = deriveSecret h secret label $ TranscriptHash ""+                secret' = deriveSecret h secret label $ TranscriptHash $ hash h ""                 label' = "exporter"                 value' = hash h context                 key = hkdfExpandLabel h secret' label' value' outlen              in Just key         _ -> Nothing --- | Getting the "tls-server-end-point" channel binding for TLS 1.2---   (RFC5929).  For 1.3, there is no specifications for how to create---   it.  In this implementation, a certificate chain without---   extensions is hashed like TLS 1.2.+-- | Getting the "tls-server-end-point" channel binding (RFC5929).+--+--   This hashes the server's leaf certificate, exactly as it appears in the+--   Certificate message, with the hash its own signature names, and with+--   SHA-256 standing in for MD5 and SHA-1.  Since it depends on nothing but+--   the certificate, it is computed for TLS 1.2 and for+--   certificate-authenticated TLS 1.3 alike -- though RFC 5929 predates TLS+--   1.3 and no RFC defines it there.+--+--   'Nothing' is returned when there is no server certificate, as on a+--   resumption or with a pre-shared key, and when the certificate's+--   signature names no hash to use: an Ed25519 or Ed448 signature names the+--   whole scheme and the binding is undefined for it. getTLSServerEndPoint :: Context -> IO (Maybe ByteString) getTLSServerEndPoint ctx = do     mcc <- usingState_ ctx getServerCertificateChain-    case mcc of-        Nothing -> return Nothing-        Just cc -> do-            (usedHash, _, _, _) <- getRxRecordState ctx-            return $ Just $ hash usedHash $ encodeCertificate cc+    return $ mcc >>= serverEndPoint+  where+    serverEndPoint (CertificateChain (leaf : _)) =+        (\h -> hash h (X509.encodeSignedObject leaf)) <$> certificateSignatureHash leaf+    serverEndPoint _ = Nothing++    certificateSignatureHash leaf =+        case X509.signedAlg $ X509.getSigned leaf of+            X509.SignatureALG X509.HashMD5 _ -> Just SHA256+            X509.SignatureALG X509.HashSHA1 _ -> Just SHA256+            X509.SignatureALG X509.HashSHA224 _ -> Just SHA224+            X509.SignatureALG X509.HashSHA256 _ -> Just SHA256+            X509.SignatureALG X509.HashSHA384 _ -> Just SHA384+            X509.SignatureALG X509.HashSHA512 _ -> Just SHA512+            _ -> Nothing

@@ -66,6 +66,7 @@      -- * Misc     HandshakeSync (..),+    PHAResult (..),     TLS13State (..),     defaultTLS13State,     getTLS13State,@@ -118,6 +119,7 @@ import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Util+import Network.TLS.X509 (CertificateChain)  -- | A TLS Context keep tls specific state, parameters and backend information. data Context@@ -181,6 +183,7 @@     { doHandshake_ :: Context -> IO ()     , doHandshakeWith_ :: Context -> HandshakeR -> IO ()     , doRequestCertificate_ :: Context -> IO Bool+    , doRequestCertificateAsync_ :: Context -> IO (Bool -> IO PHAResult)     , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO ()     } @@ -228,8 +231,30 @@     -- Actual session id for TLS 1.2, random value for TLS 1.3     , tls13stSession :: Session     , tls13stSentExtensions :: [ExtensionID]+    , tls13stPHA :: Maybe (MVar PHAResult, TLSError)+    -- ^ server: the result of the pending post-handshake authentication,+    -- and the error given to the waiters when the connection is closed+    , tls13stPHAResponding :: Bool+    -- ^ server: the client's response has begun, so nothing else may come+    -- until its Finished     } +-- | The result of 'Network.TLS.requestCertificateAsync'.+data PHAResult+    = -- | The request could not be sent: TLS 1.2, no post_handshake_auth+      -- from the client, or another request pending.+      PHAUnavailable+    | -- | No response yet.  Only when not waiting.+      PHAPending+    | -- | The client was authenticated with this chain.+      PHAAccepted CertificateChain+    | -- | The client sent an empty certificate, accepted by+      -- @onClientCertificate@.+      PHADeclined+    | -- | The verification failed or the connection was closed.+      PHAFailed TLSError+    deriving (Eq, Show)+ defaultTLS13State :: TLS13State defaultTLS13State =     TLS13State@@ -251,6 +276,8 @@         , tls13stHsKey = Nothing         , tls13stSession = Session Nothing         , tls13stSentExtensions = []+        , tls13stPHA = Nothing+        , tls13stPHAResponding = False         }  getTLS13State :: Context -> IO TLS13State@@ -336,7 +363,7 @@ contextGetInformation ctx = do     ver <- usingState_ ctx $ gets stVersion     hstate <- getHState ctx-    let (ms, ems, cr, sr, hm13, grp, ech) =+    let (ms, ems, cr, sr, hm13, grp, ech, ssig, csig) =             case hstate of                 Just st ->                     ( hstMainSecret st@@ -346,8 +373,11 @@                     , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing                     , hstSupportedGroup st                     , hstTLS13ECHAccepted st+                    , hstServerSignatureScheme st+                    , hstClientSignatureScheme st                     )-                Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing, False)+                Nothing ->+                    (Nothing, False, Nothing, Nothing, Nothing, Nothing, False, Nothing, Nothing)     (cipher, comp) <-         readMVar (ctxRxRecordState ctx) <&> \st -> (stCipher st, stCompression st)     let accepted = case hstate of@@ -371,6 +401,8 @@                         , infoTLS13HandshakeMode = hm13                         , infoIsEarlyDataAccepted = accepted                         , infoIsECHAccepted = ech+                        , infoServerSignatureScheme = ssig+                        , infoClientSignatureScheme = csig                         }         _ -> return Nothing @@ -385,7 +417,11 @@ ctxEOF ctx = readIORef $ ctxEOF_ ctx  setEOF :: Context -> IO ()-setEOF ctx = writeIORef (ctxEOF_ ctx) True+setEOF ctx = do+    writeIORef (ctxEOF_ ctx) True+    -- Wake up those waiting for a pending post-handshake authentication.+    mpha <- tls13stPHA <$> readIORef (ctxTLS13State ctx)+    forM_ mpha $ \(mv, err) -> void $ tryPutMVar mv $ PHAFailed err  ctxCloseNotify :: Context -> IO Bool ctxCloseNotify ctx = readIORef $ ctxCloseNotify_ ctx

@@ -26,6 +26,8 @@     updateKey,     KeyUpdateRequest (..),     requestCertificate,+    requestCertificateAsync,+    PHAResult (..), ) where  import Control.Concurrent (forkIO)@@ -40,6 +42,7 @@  import Network.TLS.Context import Network.TLS.Context.Internal (+    PHAResult (..),     incrementTLS13KeyUpdateCount,     resetTLS13KeyUpdateCount,  )@@ -61,6 +64,8 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types (+    Bulk (..),+    Cipher (..),     HostName,     Role (..),  )@@ -229,6 +234,7 @@     tls13 <- tls13orLater ctx     let sendP bs             | tls13 = do+                updateKeyBeforeLimit ctx                 sendPacket13 ctx $ AppData13 bs                 -- a KeyUpdate requested from now on is answered again                 modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateResponded = False}@@ -248,6 +254,31 @@         mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3         mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) +-- RFC 9846 Section 5.5: the keys are updated before the records sent+-- under them reach the limit.  Early data cannot do so and stops there.+updateKeyBeforeLimit :: Context -> IO ()+updateKeyBeforeLimit ctx = do+    (mcipher, level, sqn) <- getTxSequence ctx+    case mcipher of+        Just cipher | sqn >= recordLimit cipher -> do+            updated <-+                if level == CryptApplicationSecret+                    then sendKeyUpdate ctx UpdateNotRequested+                    else return False+            unless updated $+                E.throwIO $+                    PostHandshake $+                        Error_Misc "the key usage limit is reached"+        _ -> return ()+  where+    -- AES-GCM allows 2^24.5 full-size records.  The sequence number of+    -- ChaCha20-Poly1305 would wrap before its limit.+    recordLimit cipher = fromMaybe forCipher $ limitRecordsPerKey $ sharedLimit $ ctxShared ctx+      where+        forCipher+            | bulkName (cipherBulk cipher) == "CHACHA20POLY1305" = 2 ^ (62 :: Int)+            | otherwise = 2 ^ (24 :: Int)+ -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received.  An empty result means EOF.  Use -- 'closeNotifyReceived' to tell an orderly closure from a truncation.@@ -314,6 +345,16 @@   where     clearPending = modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv} +    -- RFC 9846 Section 4.7.2: the client's Certificate, CertificateVerify+    -- and Finished appear consecutively.  The waiters get this error.+    checkPHAResponse = do+        responding <- tls13stPHAResponding <$> getTLS13State ctx+        when responding $ do+            let reason = "message inside a post-handshake authentication response"+                err = Error_Protocol reason UnexpectedMessage+            modifyTLS13State ctx $ \st -> st{tls13stPHA = fmap (\(mv, _) -> (mv, err)) (tls13stPHA st)}+            terminate13 ctx err AlertLevel_Fatal UnexpectedMessage reason+     -- RFC 9846 Section 6: the level is ignored.  Alerts other than the     -- closure ones are error alerts, even at the warning level.     -- UserCanceled MUST be followed by a CloseNotify.@@ -331,8 +372,9 @@         loopHandshake13 $ zip hs bs         recvData13 ctx     -- when receiving empty appdata, we just retry to get some data.-    process (AppData13 "") = recvData13 ctx+    process (AppData13 "") = checkPHAResponse >> recvData13 ctx     process (AppData13 x) = do+        checkPHAResponse         let chunkLen = C8.length x         established <- ctxEstablished ctx         case established of@@ -390,6 +432,7 @@             modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}         loopHandshake13 hbs     loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+        checkPHAResponse         when (ctxQUICMode ctx) $ do             let reason = "KeyUpdate is not allowed for QUIC"             terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason@@ -512,27 +555,29 @@             terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason         Just action -> do             -- Pending actions are executed with read+write locks, just-            -- like regular handshake code.-            withWriteLock ctx $-                handleException ctx $ do-                    case action of-                        PendingRecvAction needAligned pa -> do-                            checkAligned needAligned-                            updateTranscriptHash13 ctx hb-                            pa h-                        PendingRecvActionSelfUpdate needAligned pa -> do-                            checkAligned needAligned-                            pa hb-                        PendingRecvActionHash needAligned pa -> do-                            checkAligned needAligned-                            d <- transcriptHash ctx "Pending action"-                            updateTranscriptHash13 ctx hb-                            pa d h-                    -- Client: after receiving SH, app data is coming.-                    -- this loop tries to receive it.-                    -- App key must be installed before receiving-                    -- the app data.-                    sendCFifNecessary ctx+            -- like regular handshake code.  A failure has sent an alert,+            -- so the connection is closed.+            (`E.onException` setEOF ctx) $+                withWriteLock ctx $+                    handleException ctx $ do+                        case action of+                            PendingRecvAction needAligned pa -> do+                                checkAligned needAligned+                                updateTranscriptHash13 ctx hb+                                pa h+                            PendingRecvActionSelfUpdate needAligned pa -> do+                                checkAligned needAligned+                                pa hb+                            PendingRecvActionHash needAligned pa -> do+                                checkAligned needAligned+                                d <- transcriptHash ctx "Pending action"+                                updateTranscriptHash13 ctx hb+                                pa d h+                        -- Client: after receiving SH, app data is coming.+                        -- this loop tries to receive it.+                        -- App key must be installed before receiving+                        -- the app data.+                        sendCFifNecessary ctx   where     -- The write lock is held here, so 'handleException' sends the alert.     checkAligned needAligned = when needAligned $ do@@ -597,7 +642,7 @@ -- empty result and this is 'False', the transport was closed without -- close_notify, so the data received may be truncated. ----- @since 2.4.14+-- @since 2.5.0 closeNotifyReceived :: MonadIO m => Context -> m Bool closeNotifyReceived = liftIO . ctxCloseNotify 

@@ -145,36 +145,55 @@     pub = certPubKey cert     signed = getCertificateChainLeaf chain -getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm+getHashSignature :: SignedCertificate -> Maybe TLS.SignatureScheme getHashSignature signed =     case signedAlg $ getSigned signed of-        SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg-        SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSA hashAlg-        SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg-        SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA256)-        SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA384)-        SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA512)-        SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519)-        SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448)+        SignatureALG hashAlg PubKeyALG_RSA -> rsa hashAlg+        SignatureALG hashAlg PubKeyALG_DSA -> dsa hashAlg+        SignatureALG hashAlg PubKeyALG_EC -> ecdsa hashAlg+        SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA256+        SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA384+        SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA512+        SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just TLS.ED25519+        SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just TLS.ED448         SignatureALG_IntrinsicHash PubKeyALG_MLDSA44 -> Just TLS.MLDSA44         SignatureALG_IntrinsicHash PubKeyALG_MLDSA65 -> Just TLS.MLDSA65         SignatureALG_IntrinsicHash PubKeyALG_MLDSA87 -> Just TLS.MLDSA87         _ -> Nothing   where-    convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig)-    convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1, sig)-    convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig)-    convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig)-    convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig)-    convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig)-    convertHash _ _ = Nothing+    -- A certificate can be signed with a combination TLS 1.2 allowed and+    -- the registry never named as a scheme, MD5 and SHA-224 among them, so+    -- those have names here too.+    rsa X509.HashMD5 = Just TLS.RSA_PKCS1_MD5+    rsa X509.HashSHA1 = Just TLS.RSA_PKCS1_SHA1+    rsa X509.HashSHA224 = Just TLS.RSA_PKCS1_SHA224+    rsa X509.HashSHA256 = Just TLS.RSA_PKCS1_SHA256+    rsa X509.HashSHA384 = Just TLS.RSA_PKCS1_SHA384+    rsa X509.HashSHA512 = Just TLS.RSA_PKCS1_SHA512+    rsa _ = Nothing +    dsa X509.HashMD5 = Just TLS.DSA_MD5+    dsa X509.HashSHA1 = Just TLS.DSA_SHA1+    dsa X509.HashSHA224 = Just TLS.DSA_SHA224+    dsa X509.HashSHA256 = Just TLS.DSA_SHA256+    dsa X509.HashSHA384 = Just TLS.DSA_SHA384+    dsa X509.HashSHA512 = Just TLS.DSA_SHA512+    dsa _ = Nothing++    ecdsa X509.HashMD5 = Just TLS.ECDSA_MD5+    ecdsa X509.HashSHA1 = Just TLS.ECDSA_SHA1+    ecdsa X509.HashSHA224 = Just TLS.ECDSA_SHA224+    ecdsa X509.HashSHA256 = Just TLS.ECDSA_SECP256R1_SHA256+    ecdsa X509.HashSHA384 = Just TLS.ECDSA_SECP384R1_SHA384+    ecdsa X509.HashSHA512 = Just TLS.ECDSA_SECP521R1_SHA512+    ecdsa _ = Nothing+ -- | Checks whether certificate signatures in the chain comply with a list of -- hash/signature algorithm pairs.  Currently the verification applies only to -- the signature of the leaf certificate, and when not self-signed.  This may -- be extended to additional chain elements in the future. credentialMatchesHashSignatures-    :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool+    :: [TLS.SignatureScheme] -> Credential -> Bool credentialMatchesHashSignatures hashSigs (chain, _) =     case chain of         CertificateChain [] -> True

@@ -117,15 +117,15 @@  import Network.TLS.Crypto.Types import Network.TLS.Error-import Network.TLS.HashAndSignature+import Network.TLS.SignatureScheme import Network.TLS.Imports import Network.TLS.Packet (     getBinaryVersion,     getDNames,-    getSignatureHashAlgorithm,+    getSignatureScheme,     putBinaryVersion,     putDNames,-    putSignatureHashAlgorithm,+    putSignatureScheme,  ) import Network.TLS.Types (HostName, Ticket, Version) import Network.TLS.Wire@@ -614,7 +614,7 @@  ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm]+newtype SignatureAlgorithms = SignatureAlgorithms [SignatureScheme]     deriving (Show, Eq)  instance Extension SignatureAlgorithms where@@ -622,7 +622,7 @@     extensionEncode (SignatureAlgorithms algs) =         runPut $             putWord16 (fromIntegral (length algs * 2))-                >> mapM_ putSignatureHashAlgorithm algs+                >> mapM_ putSignatureScheme algs     extensionDecode MsgTClientHello = decodeSignatureAlgorithms     extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms     extensionDecode _ = const Nothing@@ -631,7 +631,7 @@ decodeSignatureAlgorithms = runGetMaybe $ do     len <- getWord16     sas <--        getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))+        getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh))     leftoverLen <- remaining     when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length"     when (null sas) $ fail "signature algorithms are empty"@@ -988,7 +988,7 @@  ------------------------------------------------------------ -newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm]+newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [SignatureScheme]     deriving (Show, Eq)  instance Extension SignatureAlgorithmsCert where@@ -996,7 +996,7 @@     extensionEncode (SignatureAlgorithmsCert algs) =         runPut $             putWord16 (fromIntegral (length algs * 2))-                >> mapM_ putSignatureHashAlgorithm algs+                >> mapM_ putSignatureScheme algs     extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert     extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert     extensionDecode _ = const Nothing@@ -1005,7 +1005,7 @@ decodeSignatureAlgorithmsCert = runGetMaybe $ do     len <- getWord16     SignatureAlgorithmsCert-        <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))+        <$> getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh))  ------------------------------------------------------------ 

@@ -4,12 +4,14 @@     rejectOnException,     verifyLeafKeyUsage,     verifyLeafKeyUsagePurpose,+    verifyLeafKeySize,     extractCAname, ) where  import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict+import qualified Crypto.PubKey.RSA as RSA import Data.ASN1.Types (asn1CharacterToString) import Data.ByteArray.Encoding (Base (Base64), convertToBase) import qualified Data.ByteString as B@@ -20,6 +22,7 @@     ExtKeyUsage (..),     ExtKeyUsageFlag,     ExtKeyUsagePurpose (..),+    PubKey (PubKeyRSA),     encodeSignedObject,     extensionGet,     getDistinguishedElements,@@ -114,17 +117,38 @@             Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags  verifyLeafKeyUsagePurpose-    :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m ()+    :: MonadIO m => [ExtKeyUsagePurpose] -> CertificateChain -> m () verifyLeafKeyUsagePurpose _ (CertificateChain []) = return ()-verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) =+verifyLeafKeyUsagePurpose validPurposes (CertificateChain (signed : _)) =     unless verified $         badCertificate $-            "certificate is not allowed for " ++ show validPurpose+            "certificate is not allowed for any of " ++ show validPurposes   where     cert = getCertificate signed     verified = case extensionGet (certExtensions cert) of         Nothing -> True-        Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes+        Just (ExtExtendedKeyUsage purposes) -> any (`elem` validPurposes) purposes++-- | The RSA key of the peer's leaf certificate is to be at least+-- 'supportedMinRSAKeySize' and at most 'supportedMaxRSAKeySize' bits.  The+-- keys of the rest of the chain are left to the validation of the chain.+verifyLeafKeySize :: MonadIO m => Supported -> CertificateChain -> m ()+verifyLeafKeySize _ (CertificateChain []) = return ()+verifyLeafKeySize supported (CertificateChain (signed : _)) =+    case certPubKey $ getCertificate signed of+        PubKeyRSA pk+            | bits < minBits ->+                badCertificate $+                    "RSA key of " ++ show bits ++ " bits is shorter than " ++ show minBits+            | maxBits > 0 && bits > maxBits ->+                badCertificate $+                    "RSA key of " ++ show bits ++ " bits is longer than " ++ show maxBits+          where+            bits = RSA.public_size pk * 8+        _ -> return ()+  where+    minBits = supportedMinRSAKeySize supported+    maxBits = supportedMaxRSAKeySize supported  extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert

@@ -127,7 +127,8 @@     usage <- either rejectOnException (return . wrapCertificateChecks) result     case usage of         CertificateUsageAccept -> do-            verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs+            verifyLeafKeyUsagePurpose [KeyUsagePurpose_ServerAuth] certs+            verifyLeafKeySize (ctxSupported ctx) certs             checkLeafCertificateKeyUsage         CertificateUsageReject reason ->             certificateRejected ctx (either (const []) id result) certs reason@@ -182,7 +183,7 @@ -- | Return the supported 'CertificateType' values that are -- compatible with at least one supported signature algorithm. supportedCtypes-    :: [HashAndSignatureAlgorithm]+    :: [SignatureScheme]     -> [CertificateType] supportedCtypes hashAlgs =     nub $ foldr ctfilter [] hashAlgs@@ -201,7 +202,7 @@  sigAlgsToCertTypes     :: Context-    -> [HashAndSignatureAlgorithm]+    -> [SignatureScheme]     -> [CertificateType] sigAlgsToCertTypes ctx hashSigs =     filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx@@ -309,7 +310,7 @@  ---------------------------------------------------------------- --- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with+-- | Return a most preferred 'SignatureScheme' that is compatible with -- the local key and server's signature algorithms (both already saved).  Must -- only be called for TLS versions 1.2 and up, with compatibility function -- 'signatureCompatible' or 'signatureCompatible13' based on version.@@ -319,10 +320,10 @@ -- are selected by client preference in @cHashSigs@. getLocalHashSigAlg     :: Context-    -> (PubKey -> HashAndSignatureAlgorithm -> Bool)-    -> [HashAndSignatureAlgorithm]+    -> (PubKey -> SignatureScheme -> Bool)+    -> [SignatureScheme]     -> PubKey-    -> IO HashAndSignatureAlgorithm+    -> IO SignatureScheme getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do     -- Must be present with TLS 1.2 and up.     (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata

@@ -212,6 +212,19 @@         ffGroup = findFiniteFieldGroup params         srvpub = serverDHParamsToPublic serverParams +    let bits = dhParamsGetBits params+        minBits = supportedMinDHKeySize $ ctxSupported ctx+        maxBits = supportedMaxDHKeySize $ ctxSupported ctx+    when (bits < minBits) $+        throwCore $+            Error_Protocol+                ("DH prime of " ++ show bits ++ " bits is smaller than " ++ show minBits)+                InsufficientSecurity+    when (maxBits > 0 && bits > maxBits) $+        throwCore $+            Error_Protocol+                ("DH prime of " ++ show bits ++ " bits is larger than " ++ show maxBits)+                HandshakeFailure     unless (maybe False (isSupportedGroup ctx) ffGroup) $ do         groupUsage <-             onCustomFFDHEGroup (clientHooks cparams) params srvpub

@@ -238,7 +238,7 @@             _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure     unsighash         :: SignatureAlgorithms-        -> Maybe [HashAndSignatureAlgorithm]+        -> Maybe [SignatureScheme]     unsighash (SignatureAlgorithms a) = Just a  ----------------------------------------------------------------@@ -369,7 +369,7 @@  {- Unused for now uncertsig :: SignatureAlgorithmsCert-          -> Maybe [HashAndSignatureAlgorithm]+          -> Maybe [SignatureScheme] uncertsig (SignatureAlgorithmsCert a) = Just a -} 

@@ -22,6 +22,8 @@     ensureRecvComplete,     processExtendedMainSecret,     getSessionData,+    clientLeafCertificate,+    restoreClientCertificate,     storePrivInfo,     isSupportedGroup,     checkSupportedGroup,@@ -46,6 +48,7 @@ import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.IORef (modifyIORef')+import Data.X509 (decodeSignedCertificate, encodeSignedObject)  import Network.TLS.Cipher import Network.TLS.Compression@@ -255,6 +258,24 @@         usingHState ctx $ setExtendedMainSecret True         return True +-- | The DER of the client's leaf certificate, kept in the session.  The+-- chain was validated in this handshake; the leaf tells who the client is.+clientLeafCertificate :: Context -> IO (Maybe ByteString)+clientLeafCertificate ctx = do+    mcc <- usingState_ ctx getClientCertificateChain+    return $ case mcc of+        Just (CertificateChain (leaf : _)) -> Just $ encodeSignedObject leaf+        _ -> Nothing++-- | On resumption no certificate is exchanged; the client is the one whose+-- leaf certificate the session kept.+restoreClientCertificate :: Context -> SessionData -> IO ()+restoreClientCertificate ctx sd =+    case sessionClientCertificate sd+        >>= either (const Nothing) Just . decodeSignedCertificate of+        Just leaf -> usingState_ ctx $ setClientCertificateChain $ CertificateChain [leaf]+        Nothing -> return ()+ getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do     ver <- usingState_ ctx getVersion@@ -263,6 +284,7 @@     ems <- usingHState ctx getExtendedMainSecret     cipher <- cipherID <$> usingHState ctx getPendingCipher     alpn <- usingState_ ctx getNegotiatedProtocol+    clientCert <- clientLeafCertificate ctx     let compression = 0         flags = [SessionEMS | ems]     case mms of@@ -281,6 +303,7 @@                         , sessionALPN = alpn                         , sessionMaxEarlyDataSize = 0                         , sessionFlags = flags+                        , sessionClientCertificate = clientCert                         }  -- | Store the specified keypair.  Whether the public key and private key@@ -467,6 +490,8 @@                         , hstMainSecret = hstMainSecret hshake                         , hstExtendedMainSecret = hstExtendedMainSecret hshake                         , hstSupportedGroup = hstSupportedGroup hshake+                        , hstServerSignatureScheme = hstServerSignatureScheme hshake+                        , hstClientSignatureScheme = hstClientSignatureScheme hshake                         }     updateMeasure ctx resetBytesCounters     -- mark the secure connection up and running.

@@ -60,7 +60,7 @@ import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname)-import Network.TLS.Handshake.Common (unexpected)+import Network.TLS.Handshake.Common (clientLeafCertificate, unexpected) import Network.TLS.Handshake.Key import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State@@ -156,7 +156,7 @@     :: MonadIO m     => Context     -> PubKey-    -> HashAndSignatureAlgorithm+    -> SignatureScheme     -> TranscriptHash     -> m Handshake13 makeCertVerify ctx pub hs (TranscriptHash hashValue) = do@@ -165,13 +165,14 @@             | role == ClientRole = clientContextString             | otherwise = serverContextString         target = makeTarget ctxStr hashValue+    usingHState ctx $ setSignatureScheme role hs     CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target  checkCertVerify     :: MonadIO m     => Context     -> PubKey-    -> HashAndSignatureAlgorithm+    -> SignatureScheme     -> Signature     -> ByteString     -> m Bool@@ -185,7 +186,7 @@     unless (pub `signatureCompatible13` hs) $         throwCore $             Error_Protocol-                ("signature algorithm " ++ showSignatureScheme hs ++ " does not fit the public key")+                ("signature algorithm " ++ show hs ++ " does not fit the public key")                 IllegalParameter     role <- usingState_ ctx getRole     let ctxStr@@ -193,7 +194,9 @@             | otherwise = clientContextString         target = makeTarget ctxStr hashValue         sigParams = signatureParams pub hs-    verifyPublic ctx sigParams target signature+    ok <- verifyPublic ctx sigParams target signature+    when ok $ usingHState ctx $ setSignatureScheme (invertRole role) hs+    return ok  makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do@@ -206,7 +209,7 @@     :: MonadIO m     => Context     -> PubKey-    -> HashAndSignatureAlgorithm+    -> SignatureScheme     -> ByteString     -> m Signature sign ctx pub hs target = liftIO $ do@@ -364,6 +367,7 @@     malpn <- usingState_ ctx getNegotiatedProtocol     sni <- usingState_ ctx getClientSNI     mgrp <- usingHState ctx getSupportedGroup+    clientCert <- clientLeafCertificate ctx     return         SessionData             { sessionVersion = ver@@ -376,6 +380,7 @@             , sessionALPN = malpn             , sessionMaxEarlyDataSize = maxSize             , sessionFlags = []+            , sessionClientCertificate = clientCert             }  ----------------------------------------------------------------@@ -449,32 +454,15 @@  -- some hash/signature combinations have been deprecated in TLS13 and should -- not be used-checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()+checkHashSignatureValid13 :: SignatureScheme -> IO () checkHashSignatureValid13 hs =     unless (isHashSignatureValid13 hs) $-        let msg = "invalid TLS13 hash and signature algorithm: " ++ showSignatureScheme hs+        let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs          in throwCore $ Error_Protocol msg IllegalParameter -isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool+isHashSignatureValid13 :: SignatureScheme -> Bool isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13 -{--isHashSignatureValid13 (HashIntrinsic, s) =-    s-        `elem` [ SignatureRSApssRSAeSHA256-               , SignatureRSApssRSAeSHA384-               , SignatureRSApssRSAeSHA512-               , SignatureEd25519-               , SignatureEd448-               , SignatureRSApsspssSHA256-               , SignatureRSApsspssSHA384-               , SignatureRSApsspssSHA512-               ]-isHashSignatureValid13 (h, SignatureECDSA) =-    h `elem` [HashSHA256, HashSHA384, HashSHA512]-isHashSignatureValid13 _ = False--}- ----------------------------------------------------------------  calculateEarlySecret@@ -547,6 +535,7 @@         serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf         exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf     usingState_ ctx $ setTLS13ExporterSecret exporterSecret+    logKey ctx $ ExporterSecret exporterSecret     let sts0 =             ServerTrafficSecret serverApplicationSecret0                 :: ServerTrafficSecret ApplicationSecret@@ -699,6 +688,8 @@                         , hstTLS13RTT0Status = hstTLS13RTT0Status hshake                         , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake                         , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake+                        , hstServerSignatureScheme = hstServerSignatureScheme hshake+                        , hstClientSignatureScheme = hstClientSignatureScheme hshake                         }     -- forget handshake data stored in TLS state     usingState_ ctx $ do

@@ -174,6 +174,9 @@ instance LogLabel (ClientTrafficSecret ApplicationSecret) where     labelAndKey (ClientTrafficSecret key) = ("CLIENT_TRAFFIC_SECRET_0", key) +instance LogLabel ExporterSecret where+    labelAndKey (ExporterSecret key) = ("EXPORTER_SECRET", key)+ -- NSS Key Log Format -- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format logKey :: LogLabel a => Context -> a -> IO ()

@@ -4,6 +4,7 @@     handshakeServer,     handshakeServerWith,     requestCertificateServer,+    requestCertificateAsyncServer,     keyUpdate,     sendKeyUpdate,     respondToKeyUpdate,

@@ -47,7 +47,7 @@         checkResumedCipherOffered ctx ch         throwCore $             Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure-    usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion+    usedCipher <- chooseCipher sparams TLS12 (chCiphers ch) ciphersFilteredVersion     mcred <- chooseCreds usedCipher creds signatureCreds     return (usedCipher, mcred) 

@@ -12,6 +12,7 @@ import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension+import Network.TLS.Handshake.Common (restoreClientCertificate) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature@@ -60,7 +61,7 @@     when (null ciphersFilteredVersion) $         throwCore $             Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure-    usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion+    usedCipher <- chooseCipher sparams TLS13 chCiphers ciphersFilteredVersion     let usedHash = cipherHash usedCipher         rtt0 =             lookupAndDecode@@ -209,7 +210,8 @@                     isFresh <- checkFreshness tinfo obfAge                     (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata                     if isPSKvalid && isFresh-                        then+                        then do+                            restoreClientCertificate ctx sdata                             return                                 ( psk                                 , Just (bnd, n :: Int, len)

@@ -16,7 +16,7 @@ ) where  import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..))+import Data.X509 (ExtKeyUsageFlag (..))  import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -31,11 +31,15 @@ import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Types (CipherId (..)) import Network.TLS.Util (catchException) import Network.TLS.X509 -chooseCipher :: ServerHooks -> Version -> [Cipher] -> IO Cipher-chooseCipher hooks ver candidates =+-- | The candidates come in the order of 'supportedCiphers'; with+-- 'supportedClientCipherOrder' they are put in the order of the client's+-- list before 'onCipherChoosing' sees them.+chooseCipher :: ServerParams -> Version -> [CipherId] -> [Cipher] -> IO Cipher+chooseCipher sparams ver clientCiphers candidates0 =     case find ((== cipherID selected) . cipherID) candidates of         Just cipher -> return cipher         Nothing ->@@ -44,7 +48,11 @@                     "onCipherChoosing selected a cipher outside the candidate list"                     InternalError   where-    selected = onCipherChoosing hooks ver candidates+    candidates+        | supportedClientCipherOrder (serverSupported sparams) =+            mapMaybe (\(CipherId cid) -> findCipher cid candidates0) $ nub clientCiphers+        | otherwise = candidates0+    selected = onCipherChoosing (serverHooks sparams) ver candidates  checkValidClientCertChain     :: MonadIO m => Context -> String -> m CertificateChain@@ -172,7 +180,10 @@     case usage of         CertificateUsageAccept -> do             verifyLeafKeyUsage [KeyUsage_digitalSignature] certs-            verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs+            verifyLeafKeyUsagePurpose+                (supportedClientCertificatePurposes $ serverSupported sparams)+                certs+            verifyLeafKeySize (serverSupported sparams) certs         CertificateUsageReject reason -> certificateRejected ctx [] certs reason      -- Remember cert chain for later use.@@ -186,14 +197,14 @@ -- However here the algorithms are selected according -- to server preference in 'supportedHashSignatures'. hashAndSignaturesInCommon-    :: [HashAndSignatureAlgorithm] -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]+    :: [SignatureScheme] -> [ExtensionRaw] -> [SignatureScheme] hashAndSignaturesInCommon sHashSigs exts = sHashSigs `intersect` cHashSigs   where     -- See Section 7.4.1.4.1 of RFC 5246.     defVal =-        [ (HashSHA1, SignatureECDSA)-        , (HashSHA1, SignatureRSA)-        , (HashSHA1, SignatureDSA)+        [ ECDSA_SHA1+        , RSA_PKCS1_SHA1+        , DSA_SHA1         ]     cHashSigs =         lookupAndDecode

@@ -50,6 +50,7 @@             usingState_ ctx $ do                 setSession chSession                 setTLS12SessionResuming True+            restoreClientCertificate ctx sessionData             sh <-                 makeServerHello sparams ctx usedCipher mcred chExtensions chSession             sendPacket12 ctx $ Handshake [ServerHello sh] []

@@ -299,9 +299,9 @@         loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] []  credentialsFindForSigning13-    :: [HashAndSignatureAlgorithm]+    :: [SignatureScheme]     -> Credentials-    -> Maybe (Credential, HashAndSignatureAlgorithm)+    -> Maybe (Credential, SignatureScheme) credentialsFindForSigning13 hss0 creds = loop hss0   where     loop [] = Nothing@@ -311,7 +311,7 @@  -- See credentialsFindForSigning. credentialsFindForSigning13'-    :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential+    :: SignatureScheme -> Credentials -> Maybe Credential credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l   where     forSigning cred = case credentialDigitalSignatureKey cred of

@@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Network.TLS.Handshake.Server.TLS13 (     recvClientSecondFlight13,     requestCertificateServer,+    requestCertificateAsyncServer,     keyUpdate,     sendKeyUpdate,     respondToKeyUpdate,@@ -11,6 +13,7 @@     KeyUpdateRequest (..), ) where +import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.State.Strict import Data.IORef@@ -186,7 +189,16 @@ expectCertVerify     :: MonadIO m     => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()-expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do+expectCertVerify sparams ctx th h = liftIO $ do+    -- Commit the client certificate chain to the context.+    certs <- verifyCertVerify sparams ctx th h+    usingState_ ctx $ setClientCertificateChain certs++-- | Like 'expectCertVerify' but returns the chain instead of committing+-- it, which post-handshake authentication does only after Finished.+verifyCertVerify+    :: ServerParams -> Context -> TranscriptHash -> Handshake13 -> IO CertificateChain+verifyCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = do     certs@(CertificateChain cc) <-         checkValidClientCertChain ctx "invalid client certificate chain"     pubkey <- case cc of@@ -196,33 +208,20 @@     checkDigitalSignatureKey ver pubkey     usingHState ctx $ setPublicKey pubkey     verif <- checkCertVerify ctx pubkey sigAlg sig hChCc-    clientCertVerify sparams ctx certs verif-expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13")+    clientCertVerify sparams verif+    return certs+verifyCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") -clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()-clientCertVerify sparams ctx certs verif = do-    if verif-        then do-            -- When verification succeeds, commit the-            -- client certificate chain to the context.-            ---            usingState_ ctx $ setClientCertificateChain certs-            return ()-        else do-            -- Either verification failed because of an-            -- invalid format (with an error message), or-            -- the signature is wrong.  In either case,-            -- ask the application if it wants to-            -- proceed, we will do that.-            res <- liftIO $ onUnverifiedClientCert (serverHooks sparams)-            if res-                then do-                    -- When verification fails, but the-                    -- application callbacks accepts, we-                    -- also commit the client certificate-                    -- chain to the context.-                    usingState_ ctx $ setClientCertificateChain certs-                else decryptError "verification failed"+clientCertVerify :: ServerParams -> Bool -> IO ()+clientCertVerify sparams verif =+    unless verif $ do+        -- Either verification failed because of an+        -- invalid format (with an error message), or+        -- the signature is wrong.  In either case,+        -- ask the application if it wants to+        -- proceed, we will do that.+        res <- onUnverifiedClientCert (serverHooks sparams)+        unless res $ decryptError "verification failed"  ---------------------------------------------------------------- @@ -233,7 +232,8 @@ requestCertificateServer sparams ctx = handleEx ctx $ do     tls13 <- tls13orLater ctx     supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA-    let ok = tls13 && supportsPHA+    pending <- isJust . tls13stPHA <$> getTLS13State ctx+    let ok = tls13 && supportsPHA && not pending     if ok         then newIORef [] >>= sendCertReqAndRecv         else return ok@@ -254,15 +254,80 @@             emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13             updateTranscriptHash13 ctx (clientCert13, bClientCert13)             th <- transcriptHash ctx "CH..Cert"-            unless emptyCert $ do-                (certVerify13, bCertVerify13) <- getHandshake ctx ref-                expectCertVerify sparams ctx th certVerify13-                updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+            mcerts <-+                if emptyCert+                    then return Nothing+                    else do+                        (certVerify13, bCertVerify13) <- getHandshake ctx ref+                        certs <- verifyCertVerify sparams ctx th certVerify13+                        updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+                        return $ Just certs             (finished13, _bFinished13) <- getHandshake ctx ref-            expectClientFinished ctx finished13+            thCf <- transcriptHash ctx "CH..<CF"+            expectClientFinished ctx thCf finished13+            forM_ mcerts $ usingState_ ctx . setClientCertificateChain             void $ restoreHState ctx baseHState -- fixme         return True +-- | The response is processed by 'recvData' as pending actions, so the+-- application keeps receiving data meanwhile.+requestCertificateAsyncServer+    :: ServerParams -> Context -> IO (Bool -> IO PHAResult)+requestCertificateAsyncServer sparams ctx = withWriteLock ctx $ do+    tls13 <- tls13orLater ctx+    supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA+    established <- ctxEstablished ctx+    pending <- isJust . tls13stPHA <$> getTLS13State ctx+    noActions <- null <$> readIORef (ctxPendingRecvActions ctx)+    if tls13 && supportsPHA && established == Established && not pending && noActions+        then do+            mv <- newEmptyMVar+            request mv+            return $ \block ->+                if block+                    then readMVar mv+                    else fromMaybe PHAPending <$> tryReadMVar mv+        else return $ \_ -> return PHAUnavailable+  where+    -- The actions are registered before CertificateRequest is sent, so+    -- that the response cannot reach 'recvData' first.+    request mv = do+        certReqCtx <- newCertReqContext ctx+        let certReq13 = makeCertRequest sparams ctx certReqCtx False+        baseHState <- saveHState ctx+        ref <- newIORef Nothing+        let certificate = PendingRecvAction False $ \h -> reportTo mv $ do+                modifyTLS13State ctx $ \st -> st{tls13stPHAResponding = True}+                emptyCert <- expectClientCertificate sparams ctx certReqCtx h+                pushPendingRecvAction ctx $ finished mv baseHState ref+                unless emptyCert $+                    pushPendingRecvAction ctx $+                        PendingRecvActionHash False $ \th h' -> reportTo mv $ do+                            certs <- verifyCertVerify sparams ctx th h'+                            writeIORef ref $ Just certs+        setPendingRecvActions ctx [certificate]+        modifyTLS13State ctx $ \st -> st{tls13stPHA = Just (mv, Error_EOF)}+        -- This also adds CertificateRequest to the transcript.+        sendPacket13 ctx $ Handshake13 [certReq13] []+    -- The chain verified by CertificateVerify is committed only now.+    finished mv baseHState ref = PendingRecvActionHash False $ \th h -> reportTo mv $ do+        expectClientFinished ctx th h+        void $ restoreHState ctx baseHState+        mcerts <- readIORef ref+        forM_ mcerts $ usingState_ ctx . setClientCertificateChain+        modifyTLS13State ctx $ \st ->+            st{tls13stPHA = Nothing, tls13stPHAResponding = False}+        putMVar mv $ maybe PHADeclined PHAAccepted mcerts+    -- The waiters get the error when 'recvData' has sent the alert and+    -- closed the connection, so that they do not send close_notify.+    reportTo mv f =+        f `E.catch` \(e :: E.SomeException) -> do+            let err = case E.fromException e of+                    Just (Uncontextualized e') -> e'+                    _ -> Error_Misc $ show e+            modifyTLS13State ctx $ \st -> st{tls13stPHA = Just (mv, err)}+            E.throwIO e+ -- saving appdata and key update? -- error handling getHandshake@@ -329,17 +394,16 @@             Error_Protocol "certificate context is wrong" IllegalParameter     void $ clientCertificate sparams ctx certs -expectClientFinished :: Context -> Handshake13 -> IO ()-expectClientFinished ctx (Finished13 verifyData) = do+expectClientFinished :: Context -> TranscriptHash -> Handshake13 -> IO ()+expectClientFinished ctx hChBeforeCf (Finished13 verifyData) = do     (usedHash, _, level, applicationSecretN) <- getRxRecordState ctx     unless (level == CryptApplicationSecret) $         throwCore $             Error_Protocol                 "tried post-handshake authentication without application traffic secret"                 InternalError-    hChBeforeCf <- transcriptHash ctx "CH..<CF"     checkFinished ctx usedHash applicationSecretN hChBeforeCf verifyData-expectClientFinished _ h = unexpected "Finished" $ Just $ show h+expectClientFinished _ _ h = unexpected "Finished" $ Just $ show h  terminate :: Context -> TLSError -> IO a terminate ctx err = do@@ -416,18 +480,18 @@     deriving (Eq, Show)  -- | Updating application traffic secrets for TLS 1.3.---   If this API is called for TLS 1.3, 'True' is returned.---   Otherwise, 'False' is returned.+--   If the keys are updated, 'True' is returned.+--   Otherwise, that is, for TLS 1.2 or after 2^48-1 updates, 'False' is+--   returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool updateKey ctx way = liftIO $ do     tls13 <- tls13orLater ctx-    when tls13 $ do-        let req = case way of-                OneWay -> UpdateNotRequested-                TwoWay -> UpdateRequested-        -- 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] []-            keyUpdate ctx getTxRecordState setTxRecordState-    return tls13+    if tls13+        then do+            let req = case way of+                    OneWay -> UpdateNotRequested+                    TwoWay -> UpdateRequested+            -- 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 $ sendKeyUpdate ctx req+        else return False

@@ -30,6 +30,7 @@ import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct+import Network.TLS.Types (invertRole) import Network.TLS.X509  decryptError :: MonadIO m => String -> m a@@ -51,7 +52,7 @@ certificateCompatible (PubKeyMLDSA87 _) _ = True certificateCompatible _ _ = False -signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool+signatureCompatible :: PubKey -> SignatureScheme -> Bool -- ML-DSA first, and with a refusal for every other kind of key.  The RSA -- equations below ignore the first byte, and ML-DSA's second byte is one -- RSASSA-PSS also uses, so an ML-DSA scheme reaching them would be answered@@ -62,21 +63,26 @@ signatureCompatible _ MLDSA44 = False signatureCompatible _ MLDSA65 = False signatureCompatible _ MLDSA87 = False-signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1-signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256-signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384-signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512--- Only what signatureParams implements: a combination it does not, such as+signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA1 = kxCanUseRSApkcs1 pk SHA1+signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA256 = kxCanUseRSApkcs1 pk SHA256+signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA384 = kxCanUseRSApkcs1 pk SHA384+signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA512 = kxCanUseRSApkcs1 pk SHA512+-- Only what signatureParams implements: a scheme 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+signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA256 = kxCanUseRSApss pk SHA256+signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA384 = kxCanUseRSApss pk SHA384+signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA512 = kxCanUseRSApss pk SHA512+signatureCompatible (PubKeyDSA _) DSA_SHA1 = True+signatureCompatible (PubKeyEC _) sc =+    sc+        `elem` [ ECDSA_SHA1+               , ECDSA_SECP256R1_SHA256+               , ECDSA_SECP384R1_SHA384+               , ECDSA_SECP521R1_SHA512+               ]+signatureCompatible (PubKeyEd25519 _) ED25519 = True+signatureCompatible (PubKeyEd448 _) ED448 = True+signatureCompatible _ _ = False  -- Whether the signature algorithm is for the type of the key, whatever -- its other parameters.@@ -86,53 +92,44 @@ -- which of the two a scheme is.  The ML-DSA equations come first for the -- same reason -- an ML-DSA scheme fits no other kind of key, and one -- ML-DSA size does not fit another's key.-keyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> Bool+keyTypeFits :: PubKey -> SignatureScheme -> Bool keyTypeFits (PubKeyMLDSA44 _) hs = hs == MLDSA44 keyTypeFits (PubKeyMLDSA65 _) hs = hs == MLDSA65 keyTypeFits (PubKeyMLDSA87 _) hs = hs == MLDSA87 keyTypeFits _ MLDSA44 = False keyTypeFits _ MLDSA65 = False keyTypeFits _ MLDSA87 = False-keyTypeFits (PubKeyRSA _) (_, s) =-    s-        `elem` [ SignatureRSA-               , SignatureRSApssRSAeSHA256-               , SignatureRSApssRSAeSHA384-               , SignatureRSApssRSAeSHA512-               , SignatureRSApsspssSHA256-               , SignatureRSApsspssSHA384-               , SignatureRSApsspssSHA512-               ]-keyTypeFits (PubKeyDSA _) (_, s) = s == SignatureDSA-keyTypeFits (PubKeyEC _) (_, s) = s == SignatureECDSA-keyTypeFits (PubKeyEd25519 _) (_, s) = s == SignatureEd25519-keyTypeFits (PubKeyEd448 _) (_, s) = s == SignatureEd448+keyTypeFits (PubKeyRSA _) sc = sc `elem` (rsaPkcs1Schemes ++ rsaPssSchemes)+keyTypeFits (PubKeyDSA _) sc = sc `elem` dsaSchemes+keyTypeFits (PubKeyEC _) sc = sc `elem` ecdsaSchemes+keyTypeFits (PubKeyEd25519 _) sc = sc == ED25519+keyTypeFits (PubKeyEd448 _) sc = sc == ED448 keyTypeFits _ _ = False -checkKeyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> IO ()+checkKeyTypeFits :: PubKey -> SignatureScheme -> IO () checkKeyTypeFits pubKey hs =     unless (pubKey `keyTypeFits` hs) $         throwCore $             Error_Protocol-                ( "signature algorithm "-                    ++ showSignatureScheme hs-                    ++ " is for another type of key"-                )+                ("signature algorithm " ++ show hs ++ " is for another type of key")                 IllegalParameter  -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the--- relation between hash in the HashAndSignatureAlgorithm and elliptic curve-signatureCompatible13 :: PubKey -> HashAndSignatureAlgorithm -> Bool-signatureCompatible13 (PubKeyEC ecPub) (h, SignatureECDSA) =-    maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (hashCurve h)+-- relation between hash in the SignatureScheme and elliptic curve+signatureCompatible13 :: PubKey -> SignatureScheme -> Bool+signatureCompatible13 (PubKeyEC ecPub) sc+    | sc `elem` ecdsaSchemes =+        maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (schemeCurve sc)   where-    hashCurve HashSHA256 = Just P256-    hashCurve HashSHA384 = Just P384-    hashCurve HashSHA512 = Just P521-    hashCurve _ = Nothing+    -- TLS 1.3 names the curve in the scheme; TLS 1.2 did not, and the three+    -- schemes that do not name one cannot be used there.+    schemeCurve ECDSA_SECP256R1_SHA256 = Just P256+    schemeCurve ECDSA_SECP384R1_SHA384 = Just P384+    schemeCurve ECDSA_SECP521R1_SHA512 = Just P521+    schemeCurve _ = Nothing signatureCompatible13 pub hs = signatureCompatible pub hs --- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'.+-- | Translate a 'SignatureScheme' to an acceptable 'CertificateType'. -- Perhaps this needs to take supported groups into account, so that, for -- example, if we don't support any shared ECDSA groups with the server, we -- return 'Nothing' rather than 'CertificateType_ECDSA_Sign'.@@ -150,23 +147,22 @@ -- @RSA@ as the only supported client certificate algorithm for TLS 1.3. -- -- FIXME: Add RSA_PSS_PSS signatures when supported.-hashSigToCertType :: HashAndSignatureAlgorithm -> Maybe CertificateType----hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign----hashSigToCertType (_, SignatureDSA) = Just CertificateType_DSA_Sign+hashSigToCertType :: SignatureScheme -> Maybe CertificateType ---hashSigToCertType (_, SignatureECDSA) = Just CertificateType_ECDSA_Sign+hashSigToCertType sc+    | sc `elem` rsaPkcs1Schemes = Just CertificateType_RSA_Sign+    | sc `elem` dsaSchemes = Just CertificateType_DSA_Sign+    | sc `elem` ecdsaSchemes = Just CertificateType_ECDSA_Sign ---hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256) =+hashSigToCertType RSA_PSS_RSAE_SHA256 =     Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384) =+hashSigToCertType RSA_PSS_RSAE_SHA384 =     Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512) =+hashSigToCertType RSA_PSS_RSAE_SHA512 =     Just CertificateType_RSA_Sign-hashSigToCertType (HashIntrinsic, SignatureEd25519) =+hashSigToCertType ED25519 =     Just CertificateType_Ed25519_Sign-hashSigToCertType (HashIntrinsic, SignatureEd448) =+hashSigToCertType ED448 =     Just CertificateType_Ed448_Sign -- hashSigToCertType _ = Nothing@@ -189,7 +185,7 @@     when (usedVersion < TLS13 && isMLDSA hashSigAlg) $         throwCore $             Error_Protocol-                ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is not for " ++ show usedVersion)+                ("signature algorithm " ++ show hashSigAlg ++ " is not for " ++ show usedVersion)                 IllegalParameter     checkSupportedHashSignature ctx hashSigAlg     checkKeyTypeFits pubKey hashSigAlg@@ -205,7 +201,7 @@     :: Context     -> Version     -> PubKey-    -> HashAndSignatureAlgorithm -- TLS12 only+    -> SignatureScheme -- TLS12 only     -> ByteString     -> IO DigitallySigned createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs =@@ -224,55 +220,56 @@     :: Context     -> Version     -> PubKey-    -> HashAndSignatureAlgorithm -- TLS12 only+    -> SignatureScheme -- TLS12 only     -> ByteString     -> IO CertVerifyData prepareCertificateVerifySignatureData _ctx _usedVersion pubKey hashSigAlg msgs =     return (signatureParams pubKey hashSigAlg, msgs) -signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams+signatureParams :: PubKey -> SignatureScheme -> SignatureParams -- Which of these is used is decided by the key, and signatureCompatible has -- already refused a scheme that does not fit the key, so an ML-DSA scheme -- cannot arrive at a clause for another kind of key. signatureParams (PubKeyRSA _) hashSigAlg =     case hashSigAlg of-        (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1-        (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1-        (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1-        (HashSHA1, SignatureRSA) -> RSAParams SHA1 RSApkcs1-        (HashIntrinsic, SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss-        (HashIntrinsic, SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss-        (HashIntrinsic, SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss-        (hsh, SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh)-        (_, sigAlg) ->-            error ("signature algorithm is incompatible with RSA: " ++ show sigAlg)+        RSA_PKCS1_SHA512 -> RSAParams SHA512 RSApkcs1+        RSA_PKCS1_SHA384 -> RSAParams SHA384 RSApkcs1+        RSA_PKCS1_SHA256 -> RSAParams SHA256 RSApkcs1+        RSA_PKCS1_SHA1 -> RSAParams SHA1 RSApkcs1+        RSA_PSS_RSAE_SHA512 -> RSAParams SHA512 RSApss+        RSA_PSS_RSAE_SHA384 -> RSAParams SHA384 RSApss+        RSA_PSS_RSAE_SHA256 -> RSAParams SHA256 RSApss+        sc+            | sc `elem` rsaPkcs1Schemes || sc `elem` rsaPssSchemes ->+                error ("unimplemented RSA signature scheme: " ++ show sc)+            | otherwise ->+                error ("signature scheme is incompatible with RSA: " ++ show sc) signatureParams (PubKeyDSA _) hashSigAlg =     case hashSigAlg of-        (HashSHA1, SignatureDSA) -> DSAParams-        (_, SignatureDSA) -> error "invalid DSA hash choice, only SHA1 allowed"-        (_, sigAlg) ->-            error ("signature algorithm is incompatible with DSA: " ++ show sigAlg)+        DSA_SHA1 -> DSAParams+        sc+            | sc `elem` dsaSchemes -> error "invalid DSA hash choice, only SHA1 allowed"+            | otherwise ->+                error ("signature scheme is incompatible with DSA: " ++ show sc) signatureParams (PubKeyEC _) hashSigAlg =     case hashSigAlg of-        (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512-        (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384-        (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256-        (HashSHA1, SignatureECDSA) -> ECDSAParams SHA1-        (hsh, SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh)-        (_, sigAlg) ->-            error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg)+        ECDSA_SECP521R1_SHA512 -> ECDSAParams SHA512+        ECDSA_SECP384R1_SHA384 -> ECDSAParams SHA384+        ECDSA_SECP256R1_SHA256 -> ECDSAParams SHA256+        ECDSA_SHA1 -> ECDSAParams SHA1+        sc+            | sc `elem` ecdsaSchemes ->+                error ("unimplemented ECDSA signature scheme: " ++ show sc)+            | otherwise ->+                error ("signature scheme is incompatible with ECDSA: " ++ show sc) signatureParams (PubKeyEd25519 _) hashSigAlg =     case hashSigAlg of-        (HashIntrinsic, SignatureEd25519) -> Ed25519Params-        (hsh, SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh)-        (_, sigAlg) ->-            error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg)+        ED25519 -> Ed25519Params+        sc -> error ("signature scheme is incompatible with Ed25519: " ++ show sc) signatureParams (PubKeyEd448 _) hashSigAlg =     case hashSigAlg of-        (HashIntrinsic, SignatureEd448) -> Ed448Params-        (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh)-        (_, sigAlg) ->-            error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg)+        ED448 -> Ed448Params+        sc -> error ("signature scheme is incompatible with Ed448: " ++ show sc) signatureParams (PubKeyMLDSA44 _) MLDSA44 = MLDSA44Params signatureParams (PubKeyMLDSA65 _) MLDSA65 = MLDSA65Params signatureParams (PubKeyMLDSA87 _) MLDSA87 = MLDSA87Params@@ -280,11 +277,12 @@  signatureCreateWithCertVerifyData     :: Context-    -> HashAndSignatureAlgorithm+    -> SignatureScheme     -> CertVerifyData     -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do     role <- usingState_ ctx getRole+    usingHState ctx $ setSignatureScheme role malg     DigitallySigned malg <$> signPrivate ctx role sigParam toSign  signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool@@ -314,13 +312,17 @@     -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned hs bs) (sigParam, toVerify) = do     checkSupportedHashSignature ctx hs-    verifyPublic ctx sigParam toVerify bs+    ok <- verifyPublic ctx sigParam toVerify bs+    when ok $ do+        role <- usingState_ ctx getRole+        usingHState ctx $ setSignatureScheme (invertRole role) hs+    return ok  digitallySignParams     :: Context     -> ByteString     -> PubKey-    -> HashAndSignatureAlgorithm+    -> SignatureScheme     -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg =     let sigParam = signatureParams pubKey hashSigAlg@@ -333,7 +335,7 @@     :: Context     -> ServerDHParams     -> PubKey-    -> HashAndSignatureAlgorithm -- TLS12 only+    -> SignatureScheme -- TLS12 only     -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do     dhParamsData <-@@ -344,7 +346,7 @@     :: Context     -> ServerECDHParams     -> PubKey-    -> HashAndSignatureAlgorithm -- TLS12 only+    -> SignatureScheme -- TLS12 only     -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do     ecdhParamsData <-@@ -384,8 +386,8 @@ -- verify that the hash and signature selected by the peer is supported in -- the local configuration checkSupportedHashSignature-    :: Context -> HashAndSignatureAlgorithm -> IO ()+    :: Context -> SignatureScheme -> IO () checkSupportedHashSignature ctx hs =     unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $-        let msg = "unsupported hash and signature algorithm: " ++ showSignatureScheme hs+        let msg = "unsupported hash and signature algorithm: " ++ show hs          in throwCore $ Error_Protocol msg IllegalParameter

@@ -48,6 +48,7 @@     setCertReqCBdata,     getCertReqCBdata,     setCertReqSigAlgsCert,+    setSignatureScheme,     getCertReqSigAlgsCert,      -- * digest accessors@@ -135,7 +136,7 @@     -- ^ Set to Just-value when a TLS13 certificate request is received     , hstCertReqCBdata :: Maybe CertReqCBdata     -- ^ Set to Just-value when a certificate request is received-    , hstCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm]+    , hstCertReqSigAlgsCert :: Maybe [SignatureScheme]     -- ^ In TLS 1.3, these are separate from the certificate     -- issuer signature algorithm hints in the callback data.     -- In TLS 1.2 the same list is overloaded for both purposes.@@ -148,6 +149,9 @@     , hstClientCertChain :: Maybe CertificateChain     , hstPendingTxState :: Maybe RecordState     , hstPendingRxState :: Maybe RecordState+    , hstServerSignatureScheme :: Maybe SignatureScheme+    , hstClientSignatureScheme :: Maybe SignatureScheme+    -- ^ The schemes of the handshake signatures each side made     , hstRxSwitched :: Bool     -- ^ Set when the peer's ChangeCipherSpec switched the Rx state     , hstPendingCipher :: Maybe Cipher@@ -215,7 +219,7 @@ --    present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata =     ( [CertificateType]-    , Maybe [HashAndSignatureAlgorithm]+    , Maybe [SignatureScheme]     , [DistinguishedName]     ) @@ -251,6 +255,8 @@         , hstClientCertChain = Nothing         , hstPendingTxState = Nothing         , hstPendingRxState = Nothing+        , hstServerSignatureScheme = Nothing+        , hstClientSignatureScheme = Nothing         , hstRxSwitched = False         , hstPendingCipher = Nothing         , hstPendingCompression = nullCompression@@ -448,11 +454,16 @@ getCertReqCBdata :: HandshakeM (Maybe CertReqCBdata) getCertReqCBdata = gets hstCertReqCBdata +-- | Record the scheme of a handshake signature that the given side made.+setSignatureScheme :: Role -> SignatureScheme -> HandshakeM ()+setSignatureScheme ServerRole sc = modify' $ \hst -> hst{hstServerSignatureScheme = Just sc}+setSignatureScheme ClientRole sc = modify' $ \hst -> hst{hstClientSignatureScheme = Just sc}+ -- Dead code, until we find some use for the extension-setCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] -> HandshakeM ()+setCertReqSigAlgsCert :: Maybe [SignatureScheme] -> HandshakeM () setCertReqSigAlgsCert as = modify' $ \hst -> hst{hstCertReqSigAlgsCert = as} -getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm])+getCertReqSigAlgsCert :: HandshakeM (Maybe [SignatureScheme]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert  --

@@ -13,6 +13,7 @@     setRxRecordState,     getTxLevel,     getRxLevel,+    getTxSequence,     clearTxRecordState,     clearRxRecordState,     PendingRecvAction (..),@@ -54,6 +55,12 @@ -- So, fromJust causes an error. getTxLevel :: Context -> IO CryptLevel getTxLevel ctx = getXLevel ctx ctxTxRecordState++-- | The cipher, the level and the sequence number of the next record sent.+getTxSequence :: Context -> IO (Maybe Cipher, CryptLevel, Word64)+getTxSequence ctx = do+    tx <- readMVar $ ctxTxRecordState ctx+    return (stCipher tx, stCryptLevel tx, msSequence $ stMacState tx)  getRxLevel :: Context -> IO CryptLevel getRxLevel ctx = getXLevel ctx ctxRxRecordState

@@ -1,238 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}--module Network.TLS.HashAndSignature (-    HashAlgorithm (-        ..,-        HashNone,-        HashMD5,-        HashSHA1,-        HashSHA224,-        HashSHA256,-        HashSHA384,-        HashSHA512,-        HashIntrinsic,-        HashMLDSA-    ),-    SignatureAlgorithm (-        ..,-        SignatureAnonymous,-        SignatureRSA,-        SignatureDSA,-        SignatureECDSA,-        SignatureRSApssRSAeSHA256,-        SignatureRSApssRSAeSHA384,-        SignatureRSApssRSAeSHA512,-        SignatureEd25519,-        SignatureEd448,-        SignatureRSApsspssSHA256,-        SignatureRSApsspssSHA384,-        SignatureRSApsspssSHA512,-        SignatureBrainpoolP256,-        SignatureBrainpoolP384,-        SignatureBrainpoolP512-    ),-    HashAndSignatureAlgorithm,-    pattern MLDSA44,-    pattern MLDSA65,-    pattern MLDSA87,-    supportedSignatureSchemes,-    signatureSchemesForTLS13,-    isMLDSA,-    showSignatureScheme,-) where--import Network.TLS.Imports----------------------------------------------------------------newtype HashAlgorithm = HashAlgorithm {fromHashAlgorithm :: Word8}-    deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern HashNone      :: HashAlgorithm-pattern HashNone       = HashAlgorithm 0-pattern HashMD5       :: HashAlgorithm-pattern HashMD5        = HashAlgorithm 1-pattern HashSHA1      :: HashAlgorithm-pattern HashSHA1       = HashAlgorithm 2-pattern HashSHA224    :: HashAlgorithm-pattern HashSHA224     = HashAlgorithm 3-pattern HashSHA256    :: HashAlgorithm-pattern HashSHA256     = HashAlgorithm 4-pattern HashSHA384    :: HashAlgorithm-pattern HashSHA384     = HashAlgorithm 5-pattern HashSHA512    :: HashAlgorithm-pattern HashSHA512     = HashAlgorithm 6-pattern HashIntrinsic :: HashAlgorithm-pattern HashIntrinsic  = HashAlgorithm 8-pattern HashMLDSA     :: HashAlgorithm -- not a hash; see MLDSA44 below-pattern HashMLDSA      = HashAlgorithm 9--instance Show HashAlgorithm where-    show HashNone          = "None"-    show HashMD5           = "MD5"-    show HashSHA1          = "SHA1"-    show HashSHA224        = "SHA224"-    show HashSHA256        = "SHA256"-    show HashSHA384        = "SHA384"-    show HashSHA512        = "SHA512"-    show HashIntrinsic     = "TLS13"-    show HashMLDSA         = "MLDSA"-    show (HashAlgorithm x) = "Hash " ++ show x-{- FOURMOLU_ENABLE -}----------------------------------------------------------------newtype SignatureAlgorithm = SignatureAlgorithm {fromSignatureAlgorithm :: Word8}-    deriving (Eq)--{- FOURMOLU_DISABLE -}-pattern SignatureAnonymous        :: SignatureAlgorithm-pattern SignatureAnonymous         = SignatureAlgorithm 0-pattern SignatureRSA              :: SignatureAlgorithm-pattern SignatureRSA               = SignatureAlgorithm 1-pattern SignatureDSA              :: SignatureAlgorithm-pattern SignatureDSA               = SignatureAlgorithm 2-pattern SignatureECDSA            :: SignatureAlgorithm-pattern SignatureECDSA             = SignatureAlgorithm 3--- TLS 1.3 from here-pattern SignatureRSApssRSAeSHA256 :: SignatureAlgorithm-pattern SignatureRSApssRSAeSHA256  = SignatureAlgorithm 4-pattern SignatureRSApssRSAeSHA384 :: SignatureAlgorithm-pattern SignatureRSApssRSAeSHA384  = SignatureAlgorithm 5-pattern SignatureRSApssRSAeSHA512 :: SignatureAlgorithm-pattern SignatureRSApssRSAeSHA512  = SignatureAlgorithm 6-pattern SignatureEd25519          :: SignatureAlgorithm-pattern SignatureEd25519           = SignatureAlgorithm 7-pattern SignatureEd448            :: SignatureAlgorithm-pattern SignatureEd448             = SignatureAlgorithm 8-pattern SignatureRSApsspssSHA256  :: SignatureAlgorithm-pattern SignatureRSApsspssSHA256   = SignatureAlgorithm 9-pattern SignatureRSApsspssSHA384  :: SignatureAlgorithm-pattern SignatureRSApsspssSHA384   = SignatureAlgorithm 10-pattern SignatureRSApsspssSHA512  :: SignatureAlgorithm-pattern SignatureRSApsspssSHA512   = SignatureAlgorithm 11-pattern SignatureBrainpoolP256    :: SignatureAlgorithm -- RFC8734-pattern SignatureBrainpoolP256     = SignatureAlgorithm 26-pattern SignatureBrainpoolP384    :: SignatureAlgorithm-pattern SignatureBrainpoolP384     = SignatureAlgorithm 27-pattern SignatureBrainpoolP512    :: SignatureAlgorithm-pattern SignatureBrainpoolP512     = SignatureAlgorithm 28--instance Show SignatureAlgorithm where-    show SignatureAnonymous        = "Anonymous"-    show SignatureRSA              = "RSA"-    show SignatureDSA              = "DSA"-    show SignatureECDSA            = "ECDSA"-    show SignatureRSApssRSAeSHA256 = "RSApssRSAeSHA256"-    show SignatureRSApssRSAeSHA384 = "RSApssRSAeSHA384"-    show SignatureRSApssRSAeSHA512 = "RSApssRSAeSHA512"-    show SignatureEd25519          = "Ed25519"-    show SignatureEd448            = "Ed448"-    show SignatureRSApsspssSHA256  = "RSApsspssSHA256"-    show SignatureRSApsspssSHA384  = "RSApsspssSHA384"-    show SignatureRSApsspssSHA512  = "RSApsspssSHA512"-    show SignatureBrainpoolP256    = "BrainpoolP256"-    show SignatureBrainpoolP384    = "BrainpoolP384"-    show SignatureBrainpoolP512    = "BrainpoolP512"-    show (SignatureAlgorithm x)    = "Signature " ++ show x-{- FOURMOLU_ENABLE -}----------------------------------------------------------------type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm)---- ML-DSA, from draft-ietf-tls-mldsa: mldsa44(0x0904), mldsa65(0x0905) and--- mldsa87(0x0906).------ These are named as whole pairs rather than as a new 'SignatureAlgorithm',--- because neither byte is what it is elsewhere: 0x09 is not a hash, and the--- second byte repeats numbers RSASSA-PSS already uses.  Only the pair--- identifies the scheme, so only the pair is given a name, and code that--- decides anything about ML-DSA has to match on both bytes.---- | Name a signature scheme.------ 'show' on the pair cannot do this for ML-DSA.  A scheme is a 16-bit--- number that hs-tls carries as the two bytes it is made of, and for ML-DSA--- the size is in the second byte, whose values RSASSA-PSS also uses -- so--- the components alone render mldsa65 as @(MLDSA,RSApssRSAeSHA384)@, which--- names the wrong algorithm.  Use this wherever a scheme is put in front of--- a person.-showSignatureScheme :: HashAndSignatureAlgorithm -> String-showSignatureScheme MLDSA44 = "mldsa44"-showSignatureScheme MLDSA65 = "mldsa65"-showSignatureScheme MLDSA87 = "mldsa87"-showSignatureScheme hs = show hs---- | Is this one of the ML-DSA schemes?  They are TLS 1.3 only, so the--- TLS 1.2 paths filter them out and refuse one that arrives anyway.-isMLDSA :: HashAndSignatureAlgorithm -> Bool-isMLDSA MLDSA44 = True-isMLDSA MLDSA65 = True-isMLDSA MLDSA87 = True-isMLDSA _ = False--{- FOURMOLU_DISABLE -}-pattern MLDSA44 :: HashAndSignatureAlgorithm-pattern MLDSA44  = (HashMLDSA, SignatureAlgorithm 4)-pattern MLDSA65 :: HashAndSignatureAlgorithm-pattern MLDSA65  = (HashMLDSA, SignatureAlgorithm 5)-pattern MLDSA87 :: HashAndSignatureAlgorithm-pattern MLDSA87  = (HashMLDSA, SignatureAlgorithm 6)-{- FOURMOLU_ENABLE -}--{- FOURMOLU_DISABLE -}-supportedSignatureSchemes :: [HashAndSignatureAlgorithm]-supportedSignatureSchemes =-    -- ML-DSA algorithms, TLS 1.3 only-    [ MLDSA87                           -- mldsa87(0x0906)-    , MLDSA65                           -- mldsa65(0x0905)-    , MLDSA44                           -- mldsa44(0x0904)-    -- EdDSA algorithms-    , (HashIntrinsic, SignatureEd448)   -- ed448  (0x0808)-    , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807)-    -- ECDSA algorithms-    , (HashSHA512,    SignatureECDSA)   -- ecdsa_secp512r1_sha512(0x0603)-    , (HashSHA384,    SignatureECDSA)   -- ecdsa_secp384r1_sha384(0x0503)-    , (HashSHA256,    SignatureECDSA)   -- ecdsa_secp256r1_sha256(0x0403)-    -- RSASSA-PSS RSAE algorithms-    , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)-    , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)-    , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)-    -- RSASSA-PSS PSS algorithms with-    , (HashIntrinsic, SignatureRSApsspssSHA512)  -- rsa_pss_pss_sha512(0x080b)-    , (HashIntrinsic, SignatureRSApsspssSHA384)  -- rsa_pss_pss_sha384(0x080a)-    , (HashIntrinsic, SignatureRSApsspssSHA256)  -- rsa_pss_pss_sha256(0x0809)-    -- RSASSA-PKCS1-v1_5 algorithms-    , (HashSHA512,    SignatureRSA)    -- rsa_pkcs1_sha512(0x0601)-    , (HashSHA384,    SignatureRSA)    -- rsa_pkcs1_sha384(0x0501)-    , (HashSHA256,    SignatureRSA)    -- rsa_pkcs1_sha256(0x0401)-    -- Legacy algorithms-    , (HashSHA1,      SignatureRSA)    -- rsa_pkcs1_sha1  (0x0201)-    , (HashSHA1,      SignatureECDSA)  -- ecdsa_sha1      (0x0203)-    ]--signatureSchemesForTLS13 :: [(HashAlgorithm, SignatureAlgorithm)]-signatureSchemesForTLS13 =-    -- ML-DSA algorithms-    [ MLDSA87                           -- mldsa87(0x0906)-    , MLDSA65                           -- mldsa65(0x0905)-    , MLDSA44                           -- mldsa44(0x0904)-    -- EdDSA algorithms-    , (HashIntrinsic, SignatureEd448)   -- ed448  (0x0808)-    , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807)-    -- ECDSA algorithms-    , (HashSHA512,    SignatureECDSA)   -- ecdsa_secp512r1_sha512(0x0603)-    , (HashSHA384,    SignatureECDSA)   -- ecdsa_secp384r1_sha384(0x0503)-    , (HashSHA256,    SignatureECDSA)   -- ecdsa_secp256r1_sha256(0x0403)-    -- RSASSA-PSS RSAE algorithms-    , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806)-    , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805)-    , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804)-    -- RSASSA-PSS PSS algorithms with-    , (HashIntrinsic, SignatureRSApsspssSHA512)  -- rsa_pss_pss_sha512(0x080b)-    , (HashIntrinsic, SignatureRSApsspssSHA384)  -- rsa_pss_pss_sha384(0x080a)-    , (HashIntrinsic, SignatureRSApsspssSHA256)  -- rsa_pss_pss_sha256(0x0809)-    ]-{- FOURMOLU_ENABLE -}

@@ -40,8 +40,8 @@     generateKeyBlock,      -- * for extensions parsing-    getSignatureHashAlgorithm,-    putSignatureHashAlgorithm,+    getSignatureScheme,+    putSignatureScheme,     getBinaryVersion,     putBinaryVersion,     getClientRandom32,@@ -340,11 +340,11 @@ decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest _cp = do     certTypes <- map CertificateType <$> getWords8-    sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms+    sigHashAlgs <- getWord16 >>= getSignatureSchemes     CertRequest certTypes sigHashAlgs <$> getDNames   where-    getSignatureHashAlgorithms len =-        getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh))+    getSignatureSchemes len =+        getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh))  ---- @@ -430,11 +430,7 @@         _ -> error ("encodeHandshake': cannot handle: " ++ show skg) encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do     putWords8 (map fromCertificateType certTypes)-    putWords16 $-        map-            ( \(HashAlgorithm x, SignatureAlgorithm y) -> fromIntegral x * 256 + fromIntegral y-            )-            sigAlgs+    putWords16 $ map fromSignatureScheme sigAlgs     putDNames certAuthorities encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned@@ -530,15 +526,14 @@  ------------------------------------------------------------ -getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm-getSignatureHashAlgorithm = do-    h <- HashAlgorithm <$> getWord8-    s <- SignatureAlgorithm <$> getWord8-    return (h, s)+-- | A scheme is one 16-bit number.  It used to be read as two bytes,+-- because TLS 1.2 called them a hash and a signature algorithm, and that is+-- the reading that made @mldsa87@ arrive as @rsa_pss_rsae_sha512@.+getSignatureScheme :: Get SignatureScheme+getSignatureScheme = SignatureScheme <$> getWord16 -putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put-putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) =-    putWord8 h >> putWord8 s+putSignatureScheme :: SignatureScheme -> Put+putSignatureScheme = putWord16 . fromSignatureScheme  ------------------------------------------------------------ @@ -576,12 +571,12 @@ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver =     DigitallySigned-        <$> getSignatureHashAlgorithm+        <$> getSignatureScheme         <*> getOpaque16  putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned h sig) =-    putSignatureHashAlgorithm h >> putOpaque16 sig+    putSignatureScheme h >> putOpaque16 sig  ------------------------------------------------------------ 

@@ -73,7 +73,7 @@     putOpaque8 reqctx     putExtensions exts encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do-    putSignatureHashAlgorithm hs+    putSignatureScheme hs     putOpaque16 sig encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0@@ -209,7 +209,7 @@  decodeCertVerify13 :: Get Handshake13 decodeCertVerify13 =-    CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16)+    CertVerify13 <$> (DigitallySigned <$> getSignatureScheme <*> getOpaque16)  decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes)

@@ -34,6 +34,7 @@ import Control.Concurrent (MVar, newMVar, withMVar) import Crypto.HPKE import Data.Default (Default (def))+import Data.X509 (ExtKeyUsagePurpose (..)) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) @@ -244,6 +245,11 @@     -- ^ Server accepts this size of early data in TLS 1.3.  0 (or     -- lower) means that the server does not accept early data.     --+    -- Early data can be replayed.  The server is to accept 0-RTT for the+    -- same handshake at most once (RFC 9846 Section 8), which is left to+    -- 'sessionResumeOnlyOnce' of the session manager: the in-memory one of+    -- tls-session-manager does so, its session ticket one does not.+    --     -- Default: 0     , serverTicketLifetime :: Int     -- ^ Lifetime in seconds for session tickets generated by the@@ -296,6 +302,48 @@     -- choice.     --     -- Default: @[]@+    , supportedMinRSAKeySize :: Int+    -- ^ The least size in bits of the RSA key in the peer's leaf+    -- certificate.  A shorter one is refused with bad_certificate; 0 lets+    -- any size through.+    --+    -- Default: 2048+    , supportedMaxRSAKeySize :: Int+    -- ^ The largest size in bits of the RSA key in the peer's leaf+    -- certificate.  Verifying with a larger key costs more CPU, which the+    -- peer chooses.  A longer one is refused with bad_certificate; 0 lets+    -- any size through.+    --+    -- Default: 8192+    , supportedClientCertificatePurposes :: [ExtKeyUsagePurpose]+    -- ^ Server only.  A client's leaf certificate with Extended Key Usage+    -- is refused with bad_certificate unless it allows one of these.+    -- Adding 'KeyUsagePurpose_ServerAuth' accepts a server certificate.+    --+    -- Default: @[KeyUsagePurpose_ClientAuth]@+    --+    -- @since 2.5.0+    , supportedMinDHKeySize :: Int+    -- ^ The least size in bits of the prime of the DH parameters a TLS 1.2+    -- server sends.  A smaller one is refused with insufficient_security+    -- before 'onCustomFFDHEGroup' is called; 0 lets any size through.+    --+    -- Default: 2048, the size of the smallest group of RFC 7919+    , supportedMaxDHKeySize :: Int+    -- ^ The largest size in bits of the prime of the DH parameters a TLS+    -- 1.2 server sends.  Computing with a larger prime costs more CPU,+    -- which the server chooses.  A larger one is refused with+    -- handshake_failure before 'onCustomFFDHEGroup' is called; 0 lets any+    -- size through.+    --+    -- Default: 8192, the size of the largest group of RFC 7919+    , supportedClientCipherOrder :: Bool+    -- ^ Whether a server chooses among the ciphers in common in the+    -- client's order of preference, rather than in the order of+    -- 'supportedCiphers'.  A client without AES acceleration can then get+    -- ChaCha20-Poly1305 from a server that has it.+    --+    -- Default: 'False'     , supportedCompressions :: [Compression]     -- ^ Supported compressions methods.  By default only the "null"     -- compression is supported, which means no compression will be@@ -303,7 +351,7 @@     -- it causes a connection failure when TLS 1.3 is negotiated.     --     -- Default: @[nullCompression]@-    , supportedHashSignatures :: [HashAndSignatureAlgorithm]+    , supportedHashSignatures :: [SignatureScheme]     -- ^ All supported hash/signature algorithms pair for client     -- certificate verification and server signature in (EC)DHE,     -- ordered by decreasing priority.@@ -322,24 +370,7 @@     -- will not be used even when listed in the parameter: MD5, SHA-1,     -- SHA-224, RSA PKCS#1, DSA.     ---    -- Default:-    ---    -- @-    --   [ (HashIntrinsic,     SignatureEd448)-    --   , (HashIntrinsic,     SignatureEd25519)-    --   , (Struct.HashSHA256, SignatureECDSA)-    --   , (Struct.HashSHA384, SignatureECDSA)-    --   , (Struct.HashSHA512, SignatureECDSA)-    --   , (HashIntrinsic,     SignatureRSApssRSAeSHA512)-    --   , (HashIntrinsic,     SignatureRSApssRSAeSHA384)-    --   , (HashIntrinsic,     SignatureRSApssRSAeSHA256)-    --   , (Struct.HashSHA512, SignatureRSA)-    --   , (Struct.HashSHA384, SignatureRSA)-    --   , (Struct.HashSHA256, SignatureRSA)-    --   , (Struct.HashSHA1,   SignatureRSA)-    --   , (Struct.HashSHA1,   SignatureDSA)-    --   ]-    -- @+    -- Default: 'supportedSignatureSchemes'     , supportedSecureRenegotiation :: Bool     -- ^ Secure renegotiation defined in RFC5746.  If 'True', clients     --   send the renegotiation_info extension.  If 'True', servers@@ -450,6 +481,12 @@     Supported         { supportedVersions = [TLS13, TLS12]         , supportedCiphers = ciphersuite_default+        , supportedMinRSAKeySize = 2048+        , supportedMaxRSAKeySize = 8192+        , supportedClientCertificatePurposes = [KeyUsagePurpose_ClientAuth]+        , supportedMinDHKeySize = 2048+        , supportedMaxDHKeySize = 8192+        , supportedClientCipherOrder = False         , supportedCompressions = [nullCompression]         , supportedHashSignatures = Struct.supportedSignatureSchemes         , supportedSecureRenegotiation = True@@ -566,7 +603,7 @@ --   document readable. type OnCertificateRequest =     ( [CertificateType]-    , Maybe [HashAndSignatureAlgorithm]+    , Maybe [SignatureScheme]     , [DistinguishedName]     )     -> IO (Maybe (CertificateChain, PrivKey))@@ -611,7 +648,7 @@     --     -- The public key in the first certificate, and the matching     -- returned private key must be compatible with one of the list of-    -- 'HashAndSignatureAlgorithm' value when provided.  TLS 1.3+    -- 'SignatureScheme' value when provided.  TLS 1.3     -- changes the meaning of the list elements, adding explicit code     -- points for each supported pair of hash and signature (public     -- key) algorithms, rather than combining separate codes for the@@ -624,14 +661,21 @@     --     -- While the TLS version is not provided to the callback, the     -- content of the @signature_algorithms@ list provides a strong-    -- hint, since TLS 1.3 servers will generally list RSA pairs with-    -- a hash component of 'Intrinsic' (@0x08@).+    -- hint, since TLS 1.3 servers will generally list the RSASSA-PSS+    -- schemes, whose first octet is @0x08@.     --     -- Note that is is the responsibility of this action to select a     -- certificate matching one of the requested certificate types     -- (public key algorithms).  Returning a non-matching one will     -- lead to handshake failure later.     --+    -- 'sharedCredentials' is for servers: a client sends the certificate+    -- this action returns, for example one loaded from files.  The CA of+    -- the server belongs in 'sharedCAStore'.+    --+    -- > cred <- either error id <$> credentialLoadX509 "client.crt" "client.key"+    -- > let hooks = defaultClientHooks{onCertificateRequest = \_ -> return (Just cred)}+    --     -- Default: returns 'Nothing' anyway.     , onServerCertificate :: OnServerCertificate     -- ^ Used by the client to validate the server certificate.  The@@ -863,6 +907,12 @@     , infoTLS13HandshakeMode :: Maybe HandshakeMode13     , infoIsEarlyDataAccepted :: Bool     , infoIsECHAccepted :: Bool+    , infoServerSignatureScheme :: Maybe SignatureScheme+    -- ^ The scheme of the server's signature: ServerKeyExchange in TLS 1.2,+    -- CertificateVerify in TLS 1.3.  'Nothing' on resumption.+    , infoClientSignatureScheme :: Maybe SignatureScheme+    -- ^ The scheme of the client's CertificateVerify.  'Nothing' without a+    -- client certificate or on resumption.     }     deriving (Show, Eq) @@ -896,6 +946,15 @@     -- disable the limit; they do not disable KeyUpdate processing.     --     -- Default: @Just 32@+    , limitRecordsPerKey :: Maybe Word64+    -- ^ The number of TLS 1.3 records sent under a set of keys, after which+    -- they are updated with KeyUpdate (RFC 9846 Section 5.5).  Early data,+    -- which cannot update its keys, is refused there.  'Nothing' means the+    -- limit for the cipher: 2^24 for AES and 2^62 for ChaCha20-Poly1305.+    --+    -- Default: 'Nothing'+    --+    -- @since 2.5.0     }     deriving (Eq, Show) @@ -906,4 +965,5 @@         { limitRecordSize = Nothing         , limitHandshakeFragment = 2048         , limitKeyUpdate = Just 32+        , limitRecordsPerKey = Nothing         }

@@ -1,6 +1,8 @@ module Network.TLS.PostHandshake (     requestCertificate,     requestCertificateServer,+    requestCertificateAsync,+    requestCertificateAsyncServer,     postHandshakeAuthWith,     postHandshakeAuthClientWith, ) where@@ -15,13 +17,32 @@ ----------------------------------------------------------------  -- | Post-handshake certificate request with TLS 1.3.  Returns 'False'--- if the request was impossible, i.e. the remote client supports+-- if the request was impossible, i.e. the remote client does not support -- post-handshake authentication or the connection is established in -- TLS 1.2. Returns 'True' if the client authentication succeeds. An -- exception is thrown if the authentication fails. Server only.+--+-- This reads the client's response by itself, so it must not be called+-- while another thread is in 'recvData', and application data received+-- before the response closes the connection, against RFC 9846 Section 4.7.2.+{-# DEPRECATED+    requestCertificate+    "Application data before the response closes the connection; use requestCertificateAsync"+    #-} requestCertificate :: Context -> IO Bool requestCertificate ctx =     checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx++-- | Post-handshake certificate request with TLS 1.3, without waiting for+-- the response.  The response is processed by 'recvData', so another+-- thread or the caller itself must keep calling it.  The returned action+-- gives the result; with 'True' it blocks until the result is known, with+-- 'False' it returns 'PHAPending' meanwhile.  Only one request may be+-- pending.  'getClientCertificateChain' gives the authenticated chain.+-- Server only.+requestCertificateAsync :: Context -> IO (Bool -> IO PHAResult)+requestCertificateAsync ctx =+    checkValid ctx >> doRequestCertificateAsync_ (ctxRoleParams ctx) ctx  -- | Handle a post-handshake authentication flight with TLS 1.3.  This -- is called automatically by 'recvData', in a context where the read

@@ -13,6 +13,7 @@     -- ^ Used on TLS 1.2\/1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'.     , sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData)     -- ^ Used for 0RTT on TLS 1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'.+    -- It is to return the 'SessionData' at most once for an identity, or early data can be replayed (RFC 9846 Section 8); a manager that keeps no state, as with tickets, cannot.     , sessionEstablish :: SessionIDorTicket -> SessionData -> IO (Maybe Ticket)     -- ^ Used on TLS 1.2\/1.3 servers to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket' ignoring 'SessionID'. Used on TLS 1.2\/1.3 clients to store 'SessionData' with 'SessionIDorTicket' and then return 'Nothing'. For clients, only this field should be set with 'noSessionManager'.     , sessionInvalidate :: SessionIDorTicket -> IO ()

@@ -0,0 +1,304 @@+{-# LANGUAGE PatternSynonyms #-}++-- | TLS signature schemes, as RFC 8446 section 4.2.3 and the IANA+-- TLS SignatureScheme registry name them.+module Network.TLS.SignatureScheme (+    SignatureScheme (+        ..,+        -- the schemes the IANA registry names+        RSA_PKCS1_SHA1,+        ECDSA_SHA1,+        DSA_SHA1,+        RSA_PKCS1_SHA256,+        ECDSA_SECP256R1_SHA256,+        RSA_PKCS1_SHA384,+        ECDSA_SECP384R1_SHA384,+        RSA_PKCS1_SHA512,+        ECDSA_SECP521R1_SHA512,+        RSA_PSS_RSAE_SHA256,+        RSA_PSS_RSAE_SHA384,+        RSA_PSS_RSAE_SHA512,+        ED25519,+        ED448,+        RSA_PSS_PSS_SHA256,+        RSA_PSS_PSS_SHA384,+        RSA_PSS_PSS_SHA512,+        ECDSA_BRAINPOOLP256R1TLS13_SHA256,+        ECDSA_BRAINPOOLP384R1TLS13_SHA384,+        ECDSA_BRAINPOOLP512R1TLS13_SHA512,+        MLDSA44,+        MLDSA65,+        MLDSA87,++        -- the TLS 1.2 combinations it does not+        RSA_PKCS1_MD5,+        DSA_MD5,+        ECDSA_MD5,+        RSA_PKCS1_SHA224,+        DSA_SHA224,+        ECDSA_SHA224,+        DSA_SHA256,+        DSA_SHA384,+        DSA_SHA512+    ),+    HashAndSignatureAlgorithm,+    supportedSignatureSchemes,+    signatureSchemesForTLS13,+    isMLDSA,+    rsaPkcs1Schemes,+    rsaPssSchemes,+    dsaSchemes,+    ecdsaSchemes,+) where++import Numeric (showHex)++import Network.TLS.Imports++-- | A signature scheme: the 16-bit number that travels on the wire, with a+-- name for each one this library knows.+--+-- A scheme is one number, not a hash and a signature algorithm.  TLS 1.2+-- read the two bytes separately and some of the values still line up that+-- way, but from TLS 1.3 the number is indivisible, and for ML-DSA neither+-- byte means what it does elsewhere -- 0x09 is no hash, and the second byte+-- repeats numbers RSASSA-PSS uses, so @mldsa87@ read byte by byte looks+-- like @rsa_pss_rsae_sha512@.  Code that took the halves apart got that+-- wrong, which is why the halves are gone.+--+-- The names are pattern synonyms with no @COMPLETE@ pragma, so a @case@+-- over them needs a catch-all and a scheme named in a later release breaks+-- nothing that compiled against this one.  'Show' is written out for the+-- same reason: a program built against an older hs-tls still says something+-- useful about a scheme a newer one produced.+newtype SignatureScheme = SignatureScheme {fromSignatureScheme :: Word16}+    deriving (Eq, Ord)++{- FOURMOLU_DISABLE -}+pattern RSA_PKCS1_SHA1                    :: SignatureScheme+pattern RSA_PKCS1_SHA1                     = SignatureScheme 0x0201  -- RFC8446, legacy+pattern ECDSA_SHA1                        :: SignatureScheme+pattern ECDSA_SHA1                         = SignatureScheme 0x0203  -- RFC8446, legacy+pattern DSA_SHA1                          :: SignatureScheme+pattern DSA_SHA1                           = SignatureScheme 0x0202  -- TLS 1.2 only, no IANA name+pattern RSA_PKCS1_SHA256                  :: SignatureScheme+pattern RSA_PKCS1_SHA256                   = SignatureScheme 0x0401+pattern ECDSA_SECP256R1_SHA256            :: SignatureScheme+pattern ECDSA_SECP256R1_SHA256             = SignatureScheme 0x0403+pattern RSA_PKCS1_SHA384                  :: SignatureScheme+pattern RSA_PKCS1_SHA384                   = SignatureScheme 0x0501+pattern ECDSA_SECP384R1_SHA384            :: SignatureScheme+pattern ECDSA_SECP384R1_SHA384             = SignatureScheme 0x0503+pattern RSA_PKCS1_SHA512                  :: SignatureScheme+pattern RSA_PKCS1_SHA512                   = SignatureScheme 0x0601+pattern ECDSA_SECP521R1_SHA512            :: SignatureScheme+pattern ECDSA_SECP521R1_SHA512             = SignatureScheme 0x0603+pattern RSA_PSS_RSAE_SHA256               :: SignatureScheme+pattern RSA_PSS_RSAE_SHA256                = SignatureScheme 0x0804+pattern RSA_PSS_RSAE_SHA384               :: SignatureScheme+pattern RSA_PSS_RSAE_SHA384                = SignatureScheme 0x0805+pattern RSA_PSS_RSAE_SHA512               :: SignatureScheme+pattern RSA_PSS_RSAE_SHA512                = SignatureScheme 0x0806+pattern ED25519                           :: SignatureScheme+pattern ED25519                            = SignatureScheme 0x0807+pattern ED448                             :: SignatureScheme+pattern ED448                              = SignatureScheme 0x0808+pattern RSA_PSS_PSS_SHA256                :: SignatureScheme+pattern RSA_PSS_PSS_SHA256                 = SignatureScheme 0x0809+pattern RSA_PSS_PSS_SHA384                :: SignatureScheme+pattern RSA_PSS_PSS_SHA384                 = SignatureScheme 0x080a+pattern RSA_PSS_PSS_SHA512                :: SignatureScheme+pattern RSA_PSS_PSS_SHA512                 = SignatureScheme 0x080b+pattern ECDSA_BRAINPOOLP256R1TLS13_SHA256 :: SignatureScheme+pattern ECDSA_BRAINPOOLP256R1TLS13_SHA256  = SignatureScheme 0x081a  -- RFC8734+pattern ECDSA_BRAINPOOLP384R1TLS13_SHA384 :: SignatureScheme+pattern ECDSA_BRAINPOOLP384R1TLS13_SHA384  = SignatureScheme 0x081b  -- RFC8734+pattern ECDSA_BRAINPOOLP512R1TLS13_SHA512 :: SignatureScheme+pattern ECDSA_BRAINPOOLP512R1TLS13_SHA512  = SignatureScheme 0x081c  -- RFC8734+pattern MLDSA44                           :: SignatureScheme+pattern MLDSA44                            = SignatureScheme 0x0904  -- draft-ietf-tls-mldsa+pattern MLDSA65                           :: SignatureScheme+pattern MLDSA65                            = SignatureScheme 0x0905  -- draft-ietf-tls-mldsa+pattern MLDSA87                           :: SignatureScheme+pattern MLDSA87                            = SignatureScheme 0x0906  -- draft-ietf-tls-mldsa++-- TLS 1.2 wrote a hash and a signature algorithm, and some of the+-- combinations it allowed are schemes the registry never named.  They still+-- turn up: a certificate can be signed with one, and the peer's+-- signature_algorithms list is matched against the number.+pattern RSA_PKCS1_MD5                      :: SignatureScheme+pattern RSA_PKCS1_MD5                       = SignatureScheme 0x0101+pattern DSA_MD5                            :: SignatureScheme+pattern DSA_MD5                             = SignatureScheme 0x0102+pattern ECDSA_MD5                          :: SignatureScheme+pattern ECDSA_MD5                           = SignatureScheme 0x0103+pattern RSA_PKCS1_SHA224                   :: SignatureScheme+pattern RSA_PKCS1_SHA224                    = SignatureScheme 0x0301+pattern DSA_SHA224                         :: SignatureScheme+pattern DSA_SHA224                          = SignatureScheme 0x0302+pattern ECDSA_SHA224                       :: SignatureScheme+pattern ECDSA_SHA224                        = SignatureScheme 0x0303+pattern DSA_SHA256                         :: SignatureScheme+pattern DSA_SHA256                          = SignatureScheme 0x0402+pattern DSA_SHA384                         :: SignatureScheme+pattern DSA_SHA384                          = SignatureScheme 0x0502+pattern DSA_SHA512                         :: SignatureScheme+pattern DSA_SHA512                          = SignatureScheme 0x0602++-- | The IANA name, and the number for a scheme this release does not know.+instance Show SignatureScheme where+    show RSA_PKCS1_SHA1                    = "rsa_pkcs1_sha1"+    show ECDSA_SHA1                        = "ecdsa_sha1"+    show DSA_SHA1                          = "dsa_sha1"+    show RSA_PKCS1_SHA256                  = "rsa_pkcs1_sha256"+    show ECDSA_SECP256R1_SHA256            = "ecdsa_secp256r1_sha256"+    show RSA_PKCS1_SHA384                  = "rsa_pkcs1_sha384"+    show ECDSA_SECP384R1_SHA384            = "ecdsa_secp384r1_sha384"+    show RSA_PKCS1_SHA512                  = "rsa_pkcs1_sha512"+    show ECDSA_SECP521R1_SHA512            = "ecdsa_secp521r1_sha512"+    show RSA_PSS_RSAE_SHA256               = "rsa_pss_rsae_sha256"+    show RSA_PSS_RSAE_SHA384               = "rsa_pss_rsae_sha384"+    show RSA_PSS_RSAE_SHA512               = "rsa_pss_rsae_sha512"+    show ED25519                           = "ed25519"+    show ED448                             = "ed448"+    show RSA_PSS_PSS_SHA256                = "rsa_pss_pss_sha256"+    show RSA_PSS_PSS_SHA384                = "rsa_pss_pss_sha384"+    show RSA_PSS_PSS_SHA512                = "rsa_pss_pss_sha512"+    show ECDSA_BRAINPOOLP256R1TLS13_SHA256 = "ecdsa_brainpoolP256r1tls13_sha256"+    show ECDSA_BRAINPOOLP384R1TLS13_SHA384 = "ecdsa_brainpoolP384r1tls13_sha384"+    show ECDSA_BRAINPOOLP512R1TLS13_SHA512 = "ecdsa_brainpoolP512r1tls13_sha512"+    show MLDSA44                           = "mldsa44"+    show MLDSA65                           = "mldsa65"+    show MLDSA87                           = "mldsa87"+    show RSA_PKCS1_MD5                      = "rsa_pkcs1_md5"+    show DSA_MD5                            = "dsa_md5"+    show ECDSA_MD5                          = "ecdsa_md5"+    show RSA_PKCS1_SHA224                   = "rsa_pkcs1_sha224"+    show DSA_SHA224                         = "dsa_sha224"+    show ECDSA_SHA224                       = "ecdsa_sha224"+    show DSA_SHA256                         = "dsa_sha256"+    show DSA_SHA384                         = "dsa_sha384"+    show DSA_SHA512                         = "dsa_sha512"+    show (SignatureScheme n) = "signature_scheme(0x" ++ hex4 n ++ ")"+{- FOURMOLU_ENABLE -}++-- | Four hexadecimal digits, as the IANA registry writes a code point.+hex4 :: Word16 -> String+hex4 n = replicate (4 - length digits) '0' ++ digits+  where+    digits = showHex n ""++-- | Is this one of the ML-DSA schemes?  They are TLS 1.3 only, so the+-- TLS 1.2 paths filter them out and refuse one that arrives anyway.+isMLDSA :: SignatureScheme -> Bool+isMLDSA MLDSA44 = True+isMLDSA MLDSA65 = True+isMLDSA MLDSA87 = True+isMLDSA _ = False++{- FOURMOLU_DISABLE -}+-- | What a signature scheme used to be called, when it was a pair.+--+-- Kept so that code which only names the type goes on compiling.  Code that+-- took the pair apart cannot be helped by a synonym and has to say which+-- scheme it meant.+type HashAndSignatureAlgorithm = SignatureScheme+{-# DEPRECATED HashAndSignatureAlgorithm "Use SignatureScheme" #-}++-- | The schemes an RSA key signs under with PKCS#1 v1.5.+rsaPkcs1Schemes :: [SignatureScheme]+rsaPkcs1Schemes =+    [ RSA_PKCS1_MD5+    , RSA_PKCS1_SHA1+    , RSA_PKCS1_SHA224+    , RSA_PKCS1_SHA256+    , RSA_PKCS1_SHA384+    , RSA_PKCS1_SHA512+    ]++-- | The schemes an RSA key signs under with PSS, under either kind of key.+rsaPssSchemes :: [SignatureScheme]+rsaPssSchemes =+    [ RSA_PSS_RSAE_SHA256+    , RSA_PSS_RSAE_SHA384+    , RSA_PSS_RSAE_SHA512+    , RSA_PSS_PSS_SHA256+    , RSA_PSS_PSS_SHA384+    , RSA_PSS_PSS_SHA512+    ]++-- | The schemes a DSA key signs under.+dsaSchemes :: [SignatureScheme]+dsaSchemes =+    [ DSA_MD5+    , DSA_SHA1+    , DSA_SHA224+    , DSA_SHA256+    , DSA_SHA384+    , DSA_SHA512+    ]++-- | The schemes an ECDSA key signs under.+ecdsaSchemes :: [SignatureScheme]+ecdsaSchemes =+    [ ECDSA_MD5+    , ECDSA_SHA1+    , ECDSA_SHA224+    , ECDSA_SECP256R1_SHA256+    , ECDSA_SECP384R1_SHA384+    , ECDSA_SECP521R1_SHA512+    ]++-- | What this library offers, best first.+supportedSignatureSchemes :: [SignatureScheme]+supportedSignatureSchemes =+    -- ML-DSA, TLS 1.3 only+    [ MLDSA87+    , MLDSA65+    , MLDSA44+    -- EdDSA+    , ED448+    , ED25519+    -- ECDSA+    , ECDSA_SECP521R1_SHA512+    , ECDSA_SECP384R1_SHA384+    , ECDSA_SECP256R1_SHA256+    -- RSASSA-PSS with an RSAE key+    , RSA_PSS_RSAE_SHA512+    , RSA_PSS_RSAE_SHA384+    , RSA_PSS_RSAE_SHA256+    -- RSASSA-PSS with a PSS key+    , RSA_PSS_PSS_SHA512+    , RSA_PSS_PSS_SHA384+    , RSA_PSS_PSS_SHA256+    -- RSASSA-PKCS1-v1_5+    , RSA_PKCS1_SHA512+    , RSA_PKCS1_SHA384+    , RSA_PKCS1_SHA256+    -- Legacy+    , RSA_PKCS1_SHA1+    , ECDSA_SHA1+    ]++-- | The subset of 'supportedSignatureSchemes' that TLS 1.3 allows in+-- CertificateVerify.  RFC 8446 section 4.2.3 defines the+-- RSASSA-PKCS1-v1_5 schemes, and the two SHA-1 ones, for signatures in+-- certificates only.+signatureSchemesForTLS13 :: [SignatureScheme]+signatureSchemesForTLS13 =+    [ MLDSA87+    , MLDSA65+    , MLDSA44+    , ED448+    , ED25519+    , ECDSA_SECP521R1_SHA512+    , ECDSA_SECP384R1_SHA384+    , ECDSA_SECP256R1_SHA256+    , RSA_PSS_RSAE_SHA512+    , RSA_PSS_RSAE_SHA384+    , RSA_PSS_RSAE_SHA256+    , RSA_PSS_PSS_SHA512+    , RSA_PSS_PSS_SHA384+    , RSA_PSS_PSS_SHA256+    ]+{- FOURMOLU_ENABLE -}

@@ -110,7 +110,7 @@     Handshake (..),     packetType,     typeOfHandshake,-    module Network.TLS.HashAndSignature,+    module Network.TLS.SignatureScheme,     ExtensionRaw (..),     ExtensionID (..),     showCertificateChain,@@ -134,7 +134,7 @@ import Network.TLS.Crypto import Network.TLS.Error import {-# SOURCE #-} Network.TLS.Extension-import Network.TLS.HashAndSignature+import Network.TLS.SignatureScheme import Network.TLS.Imports import Network.TLS.Types @@ -198,7 +198,7 @@  type Signature = ByteString -data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature+data DigitallySigned = DigitallySigned SignatureScheme Signature     deriving (Eq)  instance Show DigitallySigned where@@ -470,7 +470,7 @@     | ServerKeyXchg ServerKeyXchgAlgorithmData     | CertRequest         [CertificateType]-        [HashAndSignatureAlgorithm]+        [SignatureScheme]         [DistinguishedName]     | CertVerify DigitallySigned     | Finished VerifyData

@@ -76,6 +76,17 @@ -- | Hold both client and server traffic secrets at the same step. type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) +-- | The exporter main secret, which RFC 8446 section 7.5 derives exported+-- keying material from, and which RFC 9266's @tls-exporter@ channel binding+-- is one use of.+newtype ExporterSecret = ExporterSecret Secret++instance Show ExporterSecret where+    show _ = "<secret>"++instance DebugShow ExporterSecret where+    debugShow (ExporterSecret bs) = showBytesHex $ convert bs+ -- Main secret for TLS 1.2 or earlier. newtype MainSecret = MainSecret Secret 

@@ -46,7 +46,11 @@     , sessionALPN :: Maybe ByteString     , sessionMaxEarlyDataSize :: Int     , sessionFlags :: [SessionFlag]-    } -- sessionFromTicket :: Bool+    , sessionClientCertificate :: Maybe ByteString+    -- ^ On a server, the DER of the leaf certificate the client was+    -- authenticated with, so that a resumed connection can tell the client.+    }+    -- sessionFromTicket :: Bool     deriving (Eq, Generic)  -- | Everything but @sessionSecret@, which renders as @\<secret\>@: whoever@@ -82,7 +86,11 @@             . shows (sessionMaxEarlyDataSize sd)             . showString ", sessionFlags = "             . shows (sessionFlags sd)+            . showString ", sessionClientCertificate = "+            . showString (maybe "Nothing" derLength (sessionClientCertificate sd))             . showChar '}'+  where+    derLength der = "Just <" ++ show (B.length der) ++ " bytes>"  -- | A 'SessionData' to build one from with record update syntax, so that a -- field added later does not break the code that builds it.@@ -99,6 +107,7 @@         , sessionALPN = Nothing         , sessionMaxEarlyDataSize = 0         , sessionFlags = []+        , sessionClientCertificate = Nothing         }  is0RTTPossible :: SessionData -> Bool

@@ -46,7 +46,7 @@             2 -> Session . Just <$> genByteString 32             _ -> return $ Session Nothing -instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where+instance {-# OVERLAPS #-} Arbitrary [SignatureScheme] where     arbitrary = shuffle supportedSignatureSchemes  instance Arbitrary DigitallySigned where

@@ -0,0 +1,297 @@+{-# LANGUAGE OverloadedStrings #-}++module ChannelBindingSpec where++import Control.Concurrent.Async (concurrently)+import Crypto.Error (CryptoFailable (..))+import qualified Crypto.Hash as H+import qualified Crypto.KDF.HKDF as HKDF+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import Crypto.Random (seedFromInteger)+import Data.ByteArray (convert)+import Data.ByteArray.Encoding (Base (Base16), convertFromBase)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C8+import Data.IORef+import Data.Word (Word8)+import Data.X509 hiding (HashMD5, HashSHA1, HashSHA256, HashSHA384)+import qualified Data.X509 as X509+import Network.TLS+import Network.TLS.Extra.Cipher+import Test.Hspec++import Certificate+import PubKey+import Run++spec :: Spec+spec = do+    describe "tls-exporter" $ do+        it "derives what RFC 8446 says, under SHA-256" $+            exporterFollowsRFC H.SHA256 cipher13_AES_128_GCM_SHA256+        it "derives what RFC 8446 says, under SHA-384" $+            exporterFollowsRFC H.SHA384 cipher13_AES_256_GCM_SHA384++    describe "tls-server-end-point" $ do+        it "hashes only a SHA-1-signed leaf with SHA-256 for TLS 1.2" $ do+            let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA1 PubKeyALG_RSA)+                params =+                    tls12Params+                        cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+                        [ RSA_PKCS1_SHA256+                        , RSA_PKCS1_SHA1+                        ]+                        credential+            bindings <- runBindings params+            endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain))+        it "maps an MD5 certificate signature to SHA-256" $ do+            let credential@(chain, _) = rsaCredential (SignatureALG X509.HashMD5 PubKeyALG_RSA)+                params =+                    tls12Params+                        cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+                        [ RSA_PKCS1_SHA256+                        , RSA_PKCS1_MD5+                        ]+                        credential+            bindings <- runBindings params+            endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain))+        it "uses a SHA-384 certificate signature instead of the cipher hash" $ do+            let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA384 PubKeyALG_RSA)+                params =+                    tls12Params+                        cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+                        [ RSA_PKCS1_SHA384+                        , RSA_PKCS1_SHA256+                        ]+                        credential+            bindings <- runBindings params+            endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA384 chain))+        it "uses the same leaf-certificate definition for TLS 1.3" $ do+            let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA256 PubKeyALG_RSA)+                params = tls13Params cipher13_AES_256_GCM_SHA384 credential+            bindings <- runBindings params+            endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain))+        it "is undefined for Ed25519 certificates" $ do+            bindings <- runBindings $ tls13Params cipher13_AES_128_GCM_SHA256 ed25519Credential+            endpointValues bindings `shouldBe` both Nothing+        it "is undefined for Ed448 certificates" $ do+            bindings <- runBindings $ tls13Params cipher13_AES_128_GCM_SHA256 ed448Credential+            endpointValues bindings `shouldBe` both Nothing++data Bindings = Bindings+    { clientBindings :: (Maybe B.ByteString, Maybe B.ByteString)+    , serverBindings :: (Maybe B.ByteString, Maybe B.ByteString)+    }++runBindings :: (ClientParams, ServerParams) -> IO Bindings+runBindings params =+    withPairContextWith (id, id) params $ \(clientContext, serverContext) -> do+        (clientResult, serverResult) <-+            concurrently (getBindings clientContext) (getBindings serverContext)+        return $ Bindings clientResult serverResult+  where+    getBindings ctx = do+        handshake ctx+        (,) <$> getTLSExporter ctx <*> getTLSServerEndPoint ctx++exporterValues :: Bindings -> (Maybe B.ByteString, Maybe B.ByteString)+exporterValues bindings =+    (fst (clientBindings bindings), fst (serverBindings bindings))++byteLists :: (Maybe B.ByteString, Maybe B.ByteString) -> (Maybe [Word8], Maybe [Word8])+byteLists (clientValue, serverValue) =+    (B.unpack <$> clientValue, B.unpack <$> serverValue)++-- | Run a TLS 1.3 handshake, take the exporter main secret out of the key+-- log, and work out the binding from RFC 8446 here, with no help from the+-- code under test.+--+-- A fixture of the library's own output cannot do this job: break the+-- derivation, regenerate the fixture, and the test passes again.  What is+-- written out below is the specification -- HKDF-Expand-Label and+-- Derive-Secret as RFC 8446 section 7.1 defines them, assembled as section+-- 7.5 and RFC 9266 section 2 say -- so the two have to agree for a reason.+exporterFollowsRFC :: H.HashAlgorithm a => a -> Cipher -> Expectation+exporterFollowsRFC alg cipher = do+    logged <- newIORef []+    let params = withKeyLogger (\line -> modifyIORef' logged (line :)) $+            tls13Params cipher ed25519Credential+    bindings <- runBindings params+    secret <- exporterSecretOf <$> readIORef logged+    let expected = tlsExporter alg secret+    byteLists (exporterValues bindings)+        `shouldBe` byteLists (Just expected, Just expected)++-- | RFC 9266 section 2: @TLS-Exporter("EXPORTER-Channel-Binding", "", 32)@,+-- which RFC 8446 section 7.5 expands to+-- @HKDF-Expand-Label(Derive-Secret(Secret, label, ""), "exporter",+-- Hash(context_value), key_length)@.  Both the @""@ that Derive-Secret is+-- given and the empty context value reach HKDF-Expand-Label as @Hash("")@,+-- which is the step that was wrong.+tlsExporter :: H.HashAlgorithm a => a -> B.ByteString -> B.ByteString+tlsExporter alg secret =+    expandLabel alg inner "exporter" (emptyHash alg) 32+  where+    inner = deriveSecret alg secret "EXPORTER-Channel-Binding"++-- | RFC 8446 section 7.1, for the empty transcript:+-- @Derive-Secret(Secret, Label, "") =+-- HKDF-Expand-Label(Secret, Label, Transcript-Hash(""), Hash.length)@.+deriveSecret+    :: H.HashAlgorithm a => a -> B.ByteString -> B.ByteString -> B.ByteString+deriveSecret alg secret label =+    expandLabel alg secret label (emptyHash alg) (H.hashDigestSize alg)++-- | RFC 8446 section 7.1, written out: the HkdfLabel structure is a 16-bit+-- length, then @"tls13 " ++ Label@ and then the context, each with a+-- one-octet length of its own.+expandLabel+    :: H.HashAlgorithm a+    => a -> B.ByteString -> B.ByteString -> B.ByteString -> Int -> B.ByteString+expandLabel alg secret label context len = HKDF.expand (prk alg) hkdfLabel len+  where+    prk :: H.HashAlgorithm h => h -> HKDF.PRK h+    prk _ = HKDF.extractSkip secret+    hkdfLabel =+        B.concat+            [ B.pack [fromIntegral (len `div` 256), fromIntegral (len `mod` 256)]+            , opaque ("tls13 " <> label)+            , opaque context+            ]+    opaque bs = B.cons (fromIntegral (B.length bs)) bs++emptyHash :: H.HashAlgorithm a => a -> B.ByteString+emptyHash alg = convert (H.hashWith alg B.empty)++-- | The exporter main secret, as the NSS key log format writes it:+-- @EXPORTER_SECRET \<client random\> \<secret\>@, in hexadecimal.+exporterSecretOf :: [String] -> B.ByteString+exporterSecretOf ls = case [w | l <- ls, "EXPORTER_SECRET" : _ : w : _ <- [words l]] of+    hexed : _ -> case convertFromBase Base16 (C8.pack hexed) of+        Right bs -> bs+        Left err -> error ("exporterSecretOf: " ++ err)+    [] -> error "exporterSecretOf: the key log has no EXPORTER_SECRET line"++withKeyLogger+    :: (String -> IO ())+    -> (ClientParams, ServerParams)+    -> (ClientParams, ServerParams)+withKeyLogger logger (cparams, sparams) =+    ( cparams+    , sparams{serverDebug = (serverDebug sparams){debugKeyLogger = logger}}+    )++endpointValues :: Bindings -> (Maybe B.ByteString, Maybe B.ByteString)+endpointValues bindings =+    (snd (clientBindings bindings), snd (serverBindings bindings))++both :: a -> (a, a)+both value = (value, value)++tls12Params+    :: Cipher+    -> [SignatureScheme]+    -> Credential+    -> (ClientParams, ServerParams)+tls12Params cipher hashSignatures =+    bindingParams TLS12 cipher hashSignatures++tls13Params :: Cipher -> Credential -> (ClientParams, ServerParams)+tls13Params cipher =+    bindingParams+        TLS13+        cipher+        [ ED448+        , ED25519+        , RSA_PSS_RSAE_SHA256+        , RSA_PKCS1_SHA256+        ]++bindingParams+    :: Version+    -> Cipher+    -> [SignatureScheme]+    -> Credential+    -> (ClientParams, ServerParams)+bindingParams version cipher hashSignatures credential =+    (clientParams, serverParams)+  where+    supported =+        defaultSupported+            { supportedVersions = [version]+            , supportedCiphers = [cipher]+            , supportedGroups = [X25519]+            , supportedGroupsTLS13 = [[X25519]]+            , supportedHashSignatures = hashSignatures+            , -- the fixed RSA key of the expected values is 1024 bits+              supportedMinRSAKeySize = 1024+            }+    clientParams =+        (defaultParamsClient "" B.empty)+            { clientSupported = supported+            , clientHooks =+                defaultClientHooks+                    { onServerCertificate = \_ _ _ _ -> return []+                    }+            , clientDebug = fixedDebug 1+            }+    serverParams =+        defaultParamsServer+            { serverSupported = supported+            , serverShared =+                defaultShared+                    { sharedCredentials = Credentials [credential]+                    }+            , serverDebug = fixedDebug 2+            }++fixedDebug :: Integer -> DebugParams+fixedDebug seed = defaultDebugParams{debugSeed = Just (seedFromInteger seed)}++rsaCredential :: SignatureALG -> Credential+rsaCredential signatureAlgorithm =+    (CertificateChain [leaf, intermediate], PrivKeyRSA privateKey)+  where+    (publicKey, privateKey) = rsaParams+    publicKey' = PubKeyRSA publicKey+    certificate =+        (simpleCertificate publicKey')+            { certSignatureAlg = signatureAlgorithm+            }+    (leaf, ()) =+        objectToSignedExact+            (\_ -> (B.replicate 128 1, signatureAlgorithm, ()))+            certificate+    intermediate = simpleX509 publicKey'++ed25519Credential :: Credential+ed25519Credential =+    ( CertificateChain [simpleX509 (PubKeyEd25519 publicKey)]+    , PrivKeyEd25519 privateKey+    )+  where+    privateKey = passed $ Ed25519.secretKey (B.pack [0 .. 31])+    publicKey = Ed25519.toPublic privateKey++ed448Credential :: Credential+ed448Credential =+    ( CertificateChain [simpleX509 (PubKeyEd448 publicKey)]+    , PrivKeyEd448 privateKey+    )+  where+    privateKey = passed $ Ed448.secretKey (B.pack [0 .. 56])+    publicKey = Ed448.toPublic privateKey++passed :: CryptoFailable a -> a+passed (CryptoPassed value) = value+passed (CryptoFailed err) = error (show err)++data DigestAlgorithm = DigestSHA256 | DigestSHA384++leafDigest :: DigestAlgorithm -> CertificateChain -> B.ByteString+leafDigest algorithm (CertificateChain (leaf : _)) =+    case algorithm of+        DigestSHA256 -> convert (H.hash (encodeSignedObject leaf) :: H.Digest H.SHA256)+        DigestSHA384 -> convert (H.hash (encodeSignedObject leaf) :: H.Digest H.SHA384)+leafDigest _ (CertificateChain []) = error "leafDigest: empty certificate chain"

@@ -218,7 +218,7 @@ trailingCases :: [(String, Bool)] trailingCases =     [ ch "supported_groups" $ SupportedGroups [X25519]-    , ch "signature_algorithms" $ SignatureAlgorithms [(HashIntrinsic, SignatureRSApssRSAeSHA256)]+    , ch "signature_algorithms" $ SignatureAlgorithms [RSA_PSS_RSAE_SHA256]     , ch "application_layer_protocol_negotiation" $         ApplicationLayerProtocolNegotiation [B.pack [0x68, 0x32]]     , ch "record_size_limit" $ RecordSizeLimit 16385

@@ -2,7 +2,14 @@  module HandshakeSpec where -import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Concurrent (+    MVar,+    forkIO,+    newEmptyMVar,+    putMVar,+    takeMVar,+    threadDelay,+ ) import Control.Concurrent.Async (concurrently_) import qualified Control.Exception as E import Control.Monad@@ -11,6 +18,7 @@ import Crypto.Error (throwCryptoError) import qualified Crypto.Hash as H import qualified Crypto.MAC.HMAC as HMAC+import qualified Crypto.PubKey.DH as DH import Data.Bits (shiftR, xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as B@@ -24,6 +32,7 @@ import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Extra.CipherCBC+import Network.TLS.Extra.FFDHE (ffdhe2048, ffdhe8192) import Network.TLS.Internal import Network.TLS.QUIC (errorToAlertDescription, hkdfExpandLabel, hkdfExtract) import Test.Hspec@@ -33,8 +42,9 @@  import API import Arbitrary-import Certificate (arbitraryRSACredentialWithPurpose)+import Certificate (arbitraryRSACredentialWithPurpose, arbitraryX509WithKey) import PipeChan+import PubKey (rsaParams) import Run import Session @@ -106,6 +116,12 @@         it "rejects a TLS 1.3 server certificate restricted to client auth" $             handshake_server_key_purpose TLS13 KeyUsagePurpose_ClientAuth False         prop "can handle client key usage" handshake_client_key_usage+        it "rejects a client certificate restricted to server auth" $+            handshake_client_key_purpose [KeyUsagePurpose_ClientAuth] False+        it "accepts a client certificate for server auth if allowed" $+            handshake_client_key_purpose+                [KeyUsagePurpose_ClientAuth, KeyUsagePurpose_ServerAuth]+                True         prop "can authenticate client" handshake_client_auth         it "rejects a TLS 1.3 CertificateVerify algorithm unfit for the key" $             handshake13_client_cert_verify_unfit_sigalg@@ -117,24 +133,52 @@                 B.pack [0x30, 0x06, 0x02, 0x01, 0x01, 0x03, 0x01, 0x09]         it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $             handshake12_client_cert_verify_sigalg-                (HashSHA256, SignatureECDSA)+                ECDSA_SECP256R1_SHA256                 rejectedAsIllegalParameter         it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $             handshake12_client_cert_verify_sigalg-                (HashIntrinsic, SignatureRSApsspssSHA256)+                RSA_PSS_PSS_SHA256                 rejectedAsDecryptError         it "rejects a TLS 1.2 ServerKeyExchange algorithm for another key type" $             handshake12_server_key_xchg_sigalg-                (HashSHA256, SignatureECDSA)+                ECDSA_SECP256R1_SHA256                 rejectedAsIllegalParameter         it "rejects a TLS 1.2 ServerKeyExchange that does not fit the RSA key" $             handshake12_server_key_xchg_sigalg-                (HashIntrinsic, SignatureRSApsspssSHA256)+                RSA_PSS_PSS_SHA256                 rejectedAsDecryptError         it "refuses a TLS 1.2 signature algorithm it cannot sign with" $             handshake12_unimplemented_sigalg+        it "reports the signature schemes of a TLS 1.2 handshake" $+            handshake_info_signature_schemes TLS12+        it "reports the signature schemes of a TLS 1.3 handshake" $+            handshake_info_signature_schemes TLS13+        it "chooses a TLS 1.2 cipher in the client's order when asked" $+            handshake_client_cipher_order+                TLS12+                cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256+                cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+        it "chooses a TLS 1.3 cipher in the client's order when asked" $+            handshake_client_cipher_order+                TLS13+                cipher13_CHACHA20_POLY1305_SHA256+                cipher13_AES_128_GCM_SHA256         it "tells why a server certificate is rejected, with the chain in PEM" $             handshake_certificate_rejection_details+        it "tells the client certificate on a TLS 1.2 resumption" $+            handshake_client_cert_on_resumption TLS12+        it "tells the client certificate on a TLS 1.3 resumption" $+            handshake_client_cert_on_resumption TLS13+        it "refuses a server certificate with a 1024-bit RSA key" $+            handshake_short_rsa_key False+        it "refuses a client certificate with a 1024-bit RSA key" $+            handshake_short_rsa_key True+        it "refuses a server certificate with an RSA key over the upper bound" $+            handshake_long_rsa_key False+        it "refuses a client certificate with an RSA key over the upper bound" $+            handshake_long_rsa_key True+        it "refuses a custom DH prime outside the bounds of its size" $+            handshake_dh_prime_size         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@@ -241,6 +285,15 @@         it "rejects an X25519MLKEM768 key share with a zero X25519 part" $             handshake13_x25519mlkem768_zero_x25519         prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth+        prop+            "delivers data while an asynchronous post-handshake auth is pending"+            post_handshake_auth_async+        it "wakes up a thread waiting for an asynchronous post-handshake auth" $+            post_handshake_auth_async_wait True+        it "fails an asynchronous post-handshake auth with a rejected certificate" $+            post_handshake_auth_async_wait False+        it "commits the client certificate of a post-handshake auth at Finished" $+            post_handshake_auth_async_finished         it             "keeps record alignment when a slow record follows client auth"             handshake13_client_auth_slow_record@@ -394,8 +447,12 @@                 params                 (\ch -> ch{chExtensions = map trailing $ chExtensions ch})                 (refusedWith DecodeError)+        it "updates the keys before the record limit" $+            handshake13_key_usage_limit         it "answers several update_requested with a single KeyUpdate" $             handshake13_single_key_update_response+        it "stops early data at the record limit" $+            handshake13_0rtt_key_usage_limit         it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $             malformed_ccs_unexpected                 TLS12@@ -672,7 +729,7 @@ --------------------------------------------------------------  handshake_hashsignatures-    :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO ()+    :: ([SignatureScheme], [SignatureScheme]) -> IO () handshake_hashsignatures (clientHashSigs, serverHashSigs) = do     tls13 <- generate arbitrary     let version = if tls13 then TLS13 else TLS12@@ -708,8 +765,10 @@         then runTLSFailure (clientParam', serverParam') handshake handshake         else runTLSSimple (clientParam', serverParam')   where-    incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256-    incompatibleWithDefaultCurve _ = False+    -- The test credential's EC key is on P-256, so any ECDSA scheme but+    -- the one that names P-256 cannot be used with it.+    incompatibleWithDefaultCurve sc =+        sc `elem` ecdsaSchemes && sc /= ECDSA_SECP256R1_SHA256  handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () handshake_ciphersuites (clientCiphers, serverCiphers) = do@@ -785,7 +844,7 @@             [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384             ]         hashSignatures =-            [ (HashSHA256, SignatureECDSA)+            [ ECDSA_SECP256R1_SHA256             ]     (clientParam, serverParam) <-         generate $@@ -817,8 +876,8 @@                         { sharedCredentials = Credentials credentials                         }                 }-        sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)-        ecdsaDenied = SignatureECDSA `notElem` sigAlgs+        sigAlgs = clientHashSignatures `intersect` serverHashSignatures+        ecdsaDenied = not (any (`elem` ecdsaSchemes) sigAlgs)     if ecdsaDenied         then runTLSFailure (clientParam', serverParam') handshake handshake         else runTLSSimple (clientParam', serverParam')@@ -845,7 +904,7 @@     let clientVersions = [TLS12]         serverVersions = [TLS12]         commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256]-        hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)]+        hashSignatures = [RSA_PKCS1_SHA256, DSA_SHA1]     chainRef <- newIORef Nothing     (clientParam, serverParam) <-         generate $@@ -879,13 +938,13 @@ -- the library, which is useful to test this scenario.  SHA-1 could be replaced -- by another algorithm. -data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm]+data OHS = OHS [SignatureScheme] [SignatureScheme]     deriving (Show)  instance Arbitrary OHS where     arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS       where-        otherHS = [(HashIntrinsic, SignatureEd25519)]+        otherHS = [ED25519]  handshake_cert_fallback_hs :: OHS -> IO () handshake_cert_fallback_hs (OHS clientHS serverHS) = do@@ -897,8 +956,8 @@             , cipher13_AES_128_GCM_SHA256             ]         commonHS =-            [ (HashSHA256, SignatureRSA)-            , (HashIntrinsic, SignatureRSApssRSAeSHA256)+            [ RSA_PKCS1_SHA256+            , RSA_PSS_RSAE_SHA256             ]     chainRef <- newIORef Nothing     (clientParam, serverParam) <-@@ -926,8 +985,8 @@                         }                 }         eddsaDisallowed =-            (HashIntrinsic, SignatureEd25519) `notElem` clientHS-                || (HashIntrinsic, SignatureEd25519) `notElem` serverHS+            ED25519 `notElem` clientHS+                || ED25519 `notElem` serverHS     runTLSSimple (clientParam', serverParam')     serverChain <- readIORef chainRef     isLeafRSA serverChain `shouldBe` eddsaDisallowed@@ -1010,6 +1069,34 @@         then runTLSSimple (clientParam', serverParam')         else runTLSFailure (clientParam', serverParam') handshake handshake +-- The client offers a certificate restricted to server auth.+handshake_client_key_purpose :: [ExtKeyUsagePurpose] -> Bool -> IO ()+handshake_client_key_purpose purposes shouldSucceed = do+    (clientParam, serverParam) <- generate arbitrary+    cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ServerAuth+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                , serverSupported =+                    (serverSupported serverParam)+                        { supportedClientCertificatePurposes = purposes+                        }+                }+    if shouldSucceed+        then runTLSSimple (clientParam', serverParam')+        else runTLSFailure (clientParam', serverParam') handshake handshake+ --------------------------------------------------------------  handshake_client_auth :: (ClientParams, ServerParams) -> IO ()@@ -1260,7 +1347,7 @@ -- that does not verify, a decrypt_error.  The client signs with an -- rsaEncryption key and the server reads the given algorithm. handshake12_client_cert_verify_sigalg-    :: HashAndSignatureAlgorithm -> Selector TLSException -> IO ()+    :: SignatureScheme -> Selector TLSException -> IO () handshake12_client_cert_verify_sigalg alg rejected = do     let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256     (clientParam, serverParam) <-@@ -1276,7 +1363,7 @@                         { onCertificateRequest = \_ -> return $ Just cred                         }                 }-        acceptUnverified = alg == (HashSHA256, SignatureECDSA)+        acceptUnverified = alg == ECDSA_SECP256R1_SHA256         serverParam' =             serverParam                 { serverWantClientCert = True@@ -1300,7 +1387,7 @@ -- The same for the signature of ServerKeyExchange, which the client used to -- answer with an ErrorCall and internal_error. handshake12_server_key_xchg_sigalg-    :: HashAndSignatureAlgorithm -> Selector TLSException -> IO ()+    :: SignatureScheme -> Selector TLSException -> IO () handshake12_server_key_xchg_sigalg alg rejected = do     let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256     (clientParam, serverParam) <-@@ -1308,7 +1395,7 @@             arbitraryPairParamsWithVersionsAndCiphers                 ([TLS12], [TLS12])                 ([cipher], [cipher])-    let (HashAlgorithm h, SignatureAlgorithm sa) = alg+    let code = fromSignatureScheme alg         unfit (ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned _ sig))) =             pure $ ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned alg sig))         -- Arriving with ServerHello, it is decoded before the cipher is@@ -1318,7 +1405,9 @@              in pure $                     ServerKeyXchg $                         SKX_Unparsed $-                            B.take off bs <> B.pack [h, sa] <> B.drop (off + 2) bs+                            B.take off bs+                                <> B.pack [fromIntegral (code `shiftR` 8), fromIntegral code]+                                <> B.drop (off + 2) bs         unfit hs = pure hs     r <- timeout 10000000 $         withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do@@ -1334,7 +1423,7 @@ handshake12_unimplemented_sigalg :: IO () handshake12_unimplemented_sigalg = do     let cipher = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256-        sha224 = defaultSupported{supportedHashSignatures = [(HashSHA224, SignatureECDSA)]}+        sha224 = defaultSupported{supportedHashSignatures = [ECDSA_SHA224]}     (clientParam, serverParam) <-         generate $             arbitraryPairParamsWithVersionsAndCiphers@@ -1361,6 +1450,172 @@                 (void (E.try (handshake cctx) :: IO (Either TLSException ())))     r `shouldSatisfy` isJust +-- A 1024-bit RSA key is shorter than the default supportedMinRSAKeySize.  It+-- is refused in the server's certificate or, with True, in the client's; a+-- lower bound lets it through.+handshake_short_rsa_key :: Bool -> IO ()+handshake_short_rsa_key clientSide = handshake_rsa_key_size clientSide id lower+  where+    lower sup = sup{supportedMinRSAKeySize = 1024}++-- The same key is longer than an upper bound of 512 bits; no upper bound lets+-- it through.+handshake_long_rsa_key :: Bool -> IO ()+handshake_long_rsa_key clientSide =+    handshake_rsa_key_size clientSide (bounds 512) (bounds 0)+  where+    bounds n sup = sup{supportedMinRSAKeySize = 0, supportedMaxRSAKeySize = n}++-- A 1024-bit RSA key in the server's certificate or, with True, in the+-- client's is refused with the first change of the verifier's 'Supported',+-- and accepted with the second.+handshake_rsa_key_size+    :: Bool -> (Supported -> Supported) -> (Supported -> Supported) -> IO ()+handshake_rsa_key_size clientSide refusing accepting = do+    let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+        (pub, priv) = rsaParams+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS12], [TLS12])+                ([cipher], [cipher])+    cert <- generate $ arbitraryX509WithKey (PubKeyRSA pub, ())+    let key = (CertificateChain [cert], PrivKeyRSA priv)+        params change+            | clientSide =+                ( clientParam+                    { clientHooks =+                        (clientHooks clientParam)+                            { onCertificateRequest = \_ -> return $ Just key+                            }+                    }+                , serverParam+                    { serverSupported = change (serverSupported serverParam)+                    , serverWantClientCert = True+                    , serverHooks =+                        (serverHooks serverParam)+                            { onClientCertificate = \_ -> return CertificateUsageAccept+                            }+                    }+                )+            | otherwise =+                ( clientParam{clientSupported = change (clientSupported clientParam)}+                , serverParam+                    { serverShared =+                        (serverShared serverParam){sharedCredentials = Credentials [key]}+                    }+                )+    withPairContextWith (id, id) (params refusing) $ \(cctx, sctx) ->+        if clientSide+            then+                concurrently_+                    (handshake sctx `shouldThrow` rejectedAsBadCertificate)+                    (void (E.try (handshake cctx) :: IO (Either TLSException ())))+            else+                concurrently_+                    (void (E.try (handshake sctx) :: IO (Either TLSException ())))+                    (handshake cctx `shouldThrow` rejectedAsBadCertificate)+    runTLSSimple (params accepting)+  where+    rejectedAsBadCertificate (HandshakeFailed (Error_Protocol _ BadCertificate)) = True+    rejectedAsBadCertificate _ = False++-- A TLS 1.2 server sends DH parameters of its own, outside the client's+-- supportedGroups.  The client refuses a prime outside supportedMinDHKeySize+-- and supportedMaxDHKeySize, whether or not it is one.  By default one of+-- 1024 or 8194 bits is refused, but ffdhe2048 and ffdhe8192 are not; with an+-- upper bound of 4096 ffdhe8192 is refused too, and with 0 for either bound+-- nothing on that side is.+handshake_dh_prime_size :: IO ()+handshake_dh_prime_size = do+    let cipher = cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS12], [TLS12])+                ([cipher], [cipher])+    let small = DH.Params (2 ^ (1023 :: Int) + 1) 2 1024+        large = DH.Params (2 ^ (8193 :: Int) + 1) 2 8194+        params (minBits, maxBits) dh =+            ( clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedGroups = [X25519]+                        , supportedMinDHKeySize = minBits+                        , supportedMaxDHKeySize = maxBits+                        }+                }+            , serverParam{serverDHEParams = Just dh}+            )+        refused ad bounds dh =+            withPairContextWith (id, id) (params bounds dh) $ \(cctx, sctx) ->+                concurrently_+                    (void (E.try (handshake sctx) :: IO (Either TLSException ())))+                    (handshake cctx `shouldThrow` refusedFor ad "DH prime")+        defaults = (2048, 8192)+    refused InsufficientSecurity defaults small+    refused HandshakeFailure defaults large+    runTLSSimple (params defaults ffdhe2048)+    runTLSSimple (params defaults ffdhe8192)+    refused HandshakeFailure (2048, 4096) ffdhe8192+    runTLSSimple (params (0, 8192) small)+    runTLSSimple (params (2048, 0) large)++-- No certificate is exchanged on resumption; the server tells the leaf the+-- session kept from the full handshake.+handshake_client_cert_on_resumption :: Version -> IO ()+handshake_client_cert_on_resumption version = do+    let cipher+            | version == TLS13 = cipher13_AES_128_GCM_SHA256+            | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                ([cipher], [cipher])+    cred@(CertificateChain (leaf : _), _) <-+        generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+    -- one group, so that no HelloRetryRequest comes in the way+    let x25519 sup = sup{supportedGroups = [X25519], supportedGroupsTLS13 = [[X25519]]}+        params0 =+            ( clientParam+                { clientSupported = x25519 (clientSupported clientParam)+                , clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+            , serverParam+                { serverWantClientCert = True+                , serverSupported = x25519 (serverSupported serverParam)+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+            )+    sessionRefs <- twoSessionRefs+    let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0+    if version == TLS13+        then runTLSSimple13 params FullHandshake+        else runTLSSimple params+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    ref <- newIORef Nothing+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params+    withPairContextWith (id, id) params2 $ \(cctx, sctx) -> do+        concurrently_ (handshake sctx) (handshake cctx)+        info <- contextGetInformation sctx+        chain <- getClientCertificateChain sctx+        writeIORef ref $ Just (info, chain)+    Just (info, chain) <- readIORef ref+    -- it was a resumption indeed+    let resumed i+            | version == TLS13 = infoTLS13HandshakeMode i == Just PreSharedKey+            | otherwise = infoTLS12Resumption i+    info `shouldSatisfy` maybe False resumed+    chain `shouldBe` Just (CertificateChain [leaf])+ -- The exception names the validation failures and the leaf, and debugError -- gets every certificate of the chain in PEM. handshake_certificate_rejection_details :: IO ()@@ -1394,6 +1649,75 @@         "[UnknownCA]" `isInfixOf` msg && "subject: " `isInfixOf` msg     rejectedWithDetails _ = False +-- The client prefers the first cipher and the server the second.  The+-- server's order wins unless supportedClientCipherOrder is set.+handshake_client_cipher_order :: Version -> Cipher -> Cipher -> IO ()+handshake_client_cipher_order version first second = do+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                ([first, second], [second, first])+    let run clientOrder = do+            ref <- newIORef Nothing+            let serverParam' =+                    serverParam+                        { serverSupported =+                            (serverSupported serverParam)+                                { supportedClientCipherOrder = clientOrder+                                }+                        }+            withPairContextWith (id, id) (clientParam, serverParam') $ \(cctx, sctx) -> do+                concurrently_ (handshake sctx) (handshake cctx)+                contextGetInformation sctx >>= writeIORef ref+            fmap (cipherID . infoCipher) <$> readIORef ref+    run False `shouldReturn` Just (cipherID second)+    run True `shouldReturn` Just (cipherID first)++-- Both sides report the same schemes: the server's signature always, and the+-- client's CertificateVerify only when it sends a certificate.+handshake_info_signature_schemes :: Version -> IO ()+handshake_info_signature_schemes version = do+    let cipher+            | version == TLS13 = cipher13_AES_128_GCM_SHA256+            | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                ([cipher], [cipher])+    cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+    let withCert send =+            ( clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ if send then Just cred else Nothing+                        }+                }+            , serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+            )+        run params = do+            ref <- newIORef Nothing+            withPairContextWith (id, id) params $ \(cctx, sctx) -> do+                concurrently_ (handshake sctx) (handshake cctx)+                ci <- contextGetInformation cctx+                si <- contextGetInformation sctx+                writeIORef ref $ Just (ci, si)+            fromJust <$> readIORef ref+        schemes i = (infoServerSignatureScheme =<< i, infoClientSignatureScheme =<< i)+    (ci, si) <- run (withCert True)+    schemes ci `shouldBe` schemes si+    schemes ci `shouldSatisfy` \(sv, cl) -> isJust sv && isJust cl+    (ci', si') <- run (withCert False)+    schemes ci' `shouldBe` schemes si'+    schemes ci' `shouldSatisfy` \(sv, cl) -> isJust sv && isNothing cl+ -- 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@@ -1472,7 +1796,7 @@                 }         unfit (CertVerify13 (DigitallySigned _ sig)) =             pure $-                CertVerify13 (DigitallySigned (HashIntrinsic, SignatureRSApsspssSHA256) sig)+                CertVerify13 (DigitallySigned RSA_PSS_PSS_SHA256 sig)         unfit hs = pure hs     r <- timeout 10000000 $         withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do@@ -2912,6 +3236,169 @@         _ <- requestCertificate ctx -- two simultaneously         sendData ctx "response 2" +type PairParams = (ClientParams, ServerParams)++-- | Client and server parameters for post-handshake authentication with+-- the credential, which the server accepts or rejects.+phaParams :: Bool -> Credential -> PairParams -> PairParams+phaParams accept cred (clientParam, serverParam) =+    ( clientParam+        { clientHooks =+            (clientHooks clientParam)+                { onCertificateRequest = \_ -> return $ Just cred+                }+        }+    , serverParam+        { serverHooks =+            (serverHooks serverParam)+                { onClientCertificate = \_ -> return usage+                }+        }+    )+  where+    usage+        | accept = CertificateUsageAccept+        | otherwise = CertificateUsageReject CertificateRejectUnknownCA++-- DSA cannot sign in TLS 1.3.+arbitraryPHACredential :: Gen Credential+arbitraryPHACredential =+    arbitraryClientCredential TLS13 `suchThat` (not . isCredentialDSA)++-- | The server requests a certificate without waiting.  The client has+-- sent "request 2" before it sees the request; the server's 'recvData'+-- delivers it and later processes the response.+post_handshake_auth_async :: CSP13 -> IO ()+post_handshake_auth_async (CSP13 params) = do+    cred <- generate arbitraryPHACredential+    runTLSSuccess (phaParams True cred params) hsClient (hsServer cred)+  where+    hsClient ctx = do+        handshake ctx+        sendData ctx "request 1"+        sendData ctx "request 2"+        recvDataAssert ctx "response 1"+        sendData ctx "request 3"+        recvDataAssert ctx "response 3"+    hsServer cred ctx = do+        handshake ctx+        recvDataAssert ctx "request 1"+        check <- requestCertificateAsync ctx+        -- only one request may be pending+        check' <- requestCertificateAsync ctx+        check' False `shouldReturn` PHAUnavailable+        sendData ctx "response 1"+        recvDataAssert ctx "request 2"+        recvDataAssert ctx "request 3"+        check False `shouldReturn` PHAAccepted (fst cred)+        getClientCertificateChain ctx `shouldReturn` Just (fst cred)+        sendData ctx "response 3"++-- | Another thread waits for the result while the server keeps reading.+-- With a rejected certificate, the server's 'recvData' fails and so does+-- the waiting thread.+post_handshake_auth_async_wait :: Bool -> IO ()+post_handshake_auth_async_wait accept = do+    params <- generate arbitraryPairParams13+    cred <- generate arbitraryPHACredential+    let params' = phaParams accept cred params+    if accept+        then runTLSSuccess params' hsClient (hsServer cred)+        else withPairContext params' $ \(cCtx, sCtx) ->+            concurrently_ (hsServer cred sCtx) (hsClient cCtx)+  where+    hsClient ctx = do+        handshake ctx+        sendData ctx "request 1"+        recvDataAssert ctx "response 1"+        sendData ctx "request 2"+        if accept+            then recvDataAssert ctx "response 2"+            else void (recvData ctx) `shouldThrow` anyTLSException+    hsServer cred ctx = do+        handshake ctx+        recvDataAssert ctx "request 1"+        check <- requestCertificateAsync ctx+        result <- newEmptyMVar+        _ <- forkIO $ check True >>= putMVar result+        sendData ctx "response 1"+        if accept+            then do+                recvDataAssert ctx "request 2"+                takeMVar result `shouldReturn` PHAAccepted (fst cred)+                sendData ctx "response 2"+            else do+                void (recvData ctx) `shouldThrow` anyTLSException+                takeMVar result >>= (`shouldSatisfy` isFailed)+    isFailed (PHAFailed _) = True+    isFailed _ = False++-- | The client's Finished is held back after its CertificateVerify has been+-- verified.  Until Finished arrives, the result is pending and the chain is+-- not committed.+post_handshake_auth_async_finished :: IO ()+post_handshake_auth_async_finished = do+    params <- generate arbitraryPairParams13+    cred <- generate arbitraryPHACredential+    let (clientParam, serverParam) = phaParams True cred params+        params' = (clientParam, serverParam{serverWantClientCert = False})+    armed <- newIORef False+    held <- newEmptyMVar+    cvSeen <- newEmptyMVar+    withPairContextWith (holdLastRecord armed held, id) params' $ \(cCtx, sCtx) -> do+        contextHookSetHandshake13Recv sCtx $ \h -> do+            case h of+                CertVerify13{} -> putMVar cvSeen ()+                _ -> return ()+            return h+        concurrently_ (hsServer cred held cvSeen sCtx) (hsClient armed cCtx)+  where+    hsClient armed ctx = do+        handshake ctx+        writeIORef armed True+        sendData ctx "request 1"+        recvDataAssert ctx "response 1"+        recvDataAssert ctx "response 2"+        sendData ctx "request 2"+    hsServer cred held cvSeen ctx = do+        handshake ctx+        recvDataAssert ctx "request 1"+        check <- requestCertificateAsync ctx+        sendData ctx "response 1"+        received <- newEmptyMVar+        _ <- forkIO $ recvData ctx >>= putMVar received+        takeMVar cvSeen+        threadDelay 100000 -- for CertificateVerify to be processed+        check False `shouldReturn` PHAPending+        getClientCertificateChain ctx `shouldReturn` Nothing+        join $ takeMVar held+        check True `shouldReturn` PHAAccepted (fst cred)+        getClientCertificateChain ctx `shouldReturn` Just (fst cred)+        sendData ctx "response 2"+        takeMVar received `shouldReturn` "request 2"++-- | Once armed, hold back the last record of the next write of several+-- records, and leave the action that sends it.+holdLastRecord :: IORef Bool -> MVar (IO ()) -> Backend -> Backend+holdLastRecord armed held be =+    be+        { backendSend = \bs -> do+            arm <- readIORef armed+            case records bs of+                rs@(_ : _ : _) | arm -> do+                    writeIORef armed False+                    backendSend be $ B.concat $ init rs+                    putMVar held $ backendSend be $ last rs+                _ -> backendSend be bs+        }+  where+    records bs+        | B.length bs < 5 = [bs | not (B.null bs)]+        | otherwise =+            let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4)+                (r, rest) = B.splitAt (5 + len) bs+             in r : records rest+ -- | After sending a Certificate message, a TLS 1.3 client peeks for a -- client-authentication alert with a deadline of a few RTTs.  That peek must -- not abandon a record it has already started reading: the record layer has no@@ -3408,6 +3895,36 @@                 )     r `shouldSatisfy` isJust +-- RFC 9846 Section 5.5: with two records allowed under a set of keys, the+-- client updates its keys before the third and the fifth of five records.+-- The server counts the KeyUpdates it receives.+handshake13_key_usage_limit :: IO ()+handshake13_key_usage_limit = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    let clientParam' =+            clientParam+                { clientShared =+                    (clientShared clientParam)+                        { sharedLimit = defaultLimit{limitRecordsPerKey = Just 2}+                        }+                }+        msgs = ["a", "b", "c", "d", "e"]+    updates <- newIORef (0 :: Int)+    let count h = do+            case h of+                KeyUpdate13 _ -> modifyIORef' updates (+ 1)+                _ -> return ()+            return h+    withPairContext (clientParam', serverParam) $ \(cctx, sctx) ->+        concurrently_+            ( do+                handshake sctx+                contextHookSetHandshake13Recv sctx count+                mapM_ (\m -> recvData sctx `shouldReturn` m) msgs+            )+            (handshake cctx >> mapM_ (sendData cctx . L.fromStrict) msgs)+    readIORef updates `shouldReturn` 2+ -- RFC 9846 Section 4.6.3: a peer that gets several KeyUpdates with -- update_requested while it sends nothing answers them once.  The server -- asks twice, and after the client's data once more.  It counts the@@ -3443,6 +3960,38 @@                 sendData cctx "y"             )     readIORef updates `shouldReturn` 2++-- Early data cannot update the keys, so it is refused at the limit.+handshake13_0rtt_key_usage_limit :: IO ()+handshake13_0rtt_key_usage_limit = 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+        pc' =+            pc+                { clientUseEarlyData = True+                , clientShared =+                    (clientShared pc){sharedLimit = defaultLimit{limitRecordsPerKey = Just 0}}+                }+    r <- timeout 10000000 $+        withPairContext (pc', ps) $ \(cctx, sctx) ->+            concurrently_+                ( void+                    (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString))+                )+                ( do+                    handshake cctx+                    sendData cctx "early" `shouldThrow` limitReached+                    bye cctx+                )+    r `shouldSatisfy` isJust+  where+    limitReached (PostHandshake (Error_Misc msg)) = "limit" `isInfixOf` msg+    limitReached _ = False  -- The client offers an unknown ticket, with a PSK of its own, before the -- one the server issued.  Each PSK has its own binder, and the server

@@ -362,8 +362,8 @@ withPairContextWith     :: (Backend -> Backend, Backend -> Backend)     -> (ClientParams, ServerParams)-    -> ((Context, Context) -> IO ())-    -> IO ()+    -> ((Context, Context) -> IO a)+    -> IO a withPairContextWith wrapBackends params body =     E.bracket         (newPairContextWith wrapBackends params)

@@ -48,6 +48,7 @@             , sessionALPN = Nothing             , sessionMaxEarlyDataSize = 0             , sessionFlags = []+            , sessionClientCertificate = Nothing             }     cipher = case ciphersuite_default of         c : _ -> c

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               tls-version:            2.4.14+version:            2.5.0 license:            BSD3 license-file:       LICENSE copyright:          Vincent Hanquez <vincent@snarc.org>@@ -81,7 +81,7 @@         Network.TLS.Handshake.State         Network.TLS.Handshake.State13         Network.TLS.Handshake.TranscriptHash-        Network.TLS.HashAndSignature+        Network.TLS.SignatureScheme         Network.TLS.Hooks         Network.TLS.IO         Network.TLS.IO.Decode@@ -131,7 +131,7 @@         crypton-x509-store >=1.10 && <1.11,         crypton-x509-validation >=1.10 && <1.11,         data-default,-        ech-config,+        ech-config >=0.0.2,         hpke >=0.4.0 && <0.5,         mtl >=2.2 && <2.4,         network >=3.1,@@ -208,6 +208,7 @@         API         Arbitrary         Certificate+        ChannelBindingSpec         CiphersSpec         ECHSpec         EncodeSpec

@@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Server where +import Control.Concurrent+import qualified Control.Exception as E import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as CL8@@ -50,25 +53,44 @@             sendData ctx $ CL8.fromStrict bs             loop +-- A dedicated thread keeps calling 'recvData', which also processes the+-- response to a post-handshake authentication. handleHTML :: Context -> Bool -> ByteString -> IO () handleHTML ctx showRequest ini = do-    getLine <- newSource ctx ini-    process getLine+    chan <- newChan+    E.bracket (forkIO $ reader chan) killThread $ \_ -> do+        getLine <- newSource chan ini+        process getLine   where+    reader chan = do+        r <- E.try $ recvData ctx+        case r of+            Right bs | bs /= "" -> writeChan chan bs >> reader chan+            Right _ -> writeChan chan ""+            Left (_ :: E.SomeException) -> writeChan chan ""     process getLine = do         bs <- getLine         when ("GET /keyupdate" `BS.isPrefixOf` bs) $ do             r <- updateKey ctx TwoWay             putStrLn $ "Updating key..." ++ if r then "OK" else "NG"-        when ("GET /secret" `BS.isPrefixOf` bs) $ do-            r <- requestCertificate ctx-            putStrLn $ "Post handshake authentication..." ++ if r then "OK" else "NG"+        mcheck <-+            if "GET /secret" `BS.isPrefixOf` bs+                then Just <$> requestCertificateAsync ctx+                else return Nothing         when (bs /= "") $ do             when showRequest $ do                 BS.putStr bs                 BS.putStr "\n"             consume getLine-            sendData ctx html+            ok <- maybe (return True) authenticated mcheck+            when ok $ sendData ctx html+    -- The response is sent only after the authentication.+    authenticated check = do+        r <- check True+        putStrLn $ "Post handshake authentication..." ++ show r+        return $ case r of+            PHAFailed _ -> False+            _ -> True     consume getLine = do         bs <- getLine         when (bs /= "") $ do@@ -77,8 +99,8 @@                 BS.putStr "\n"             consume getLine -newSource :: Context -> ByteString -> IO (IO ByteString)-newSource ctx ini = do+newSource :: Chan ByteString -> ByteString -> IO (IO ByteString)+newSource chan ini = do     ref <- newIORef ini     return $ getline ref   where@@ -87,9 +109,16 @@         bs0 <- readIORef ref         case BS.breakSubstring "\n" bs0 of             (_, "") -> do-                bs1 <- recvData ctx-                writeIORef ref (bs0 <> bs1)-                getline ref+                bs1 <- readChan chan+                if bs1 == ""+                    then do+                        -- EOF stays for the next call.+                        writeChan chan ""+                        writeIORef ref ""+                        return bs0+                    else do+                        writeIORef ref (bs0 <> bs1)+                        getline ref             (bs1, bs2) -> do                 writeIORef ref $ BS.drop 1 bs2                 return $ BS.dropWhileEnd (== 0x0d) bs1