packages feed

tls 2.1.14 → 2.4.9

raw patch · 73 files changed

Files

CHANGELOG.md view
@@ -1,5 +1,159 @@ # Change log for "tls" +## Version 2.4.9++* Include CertificateRequest in the post-handshake auth transcript.+  This breaks PHA with hs-tls 2.4.8 or earlier.+  [#565](https://github.com/haskell-tls/hs-tls/pull/565)+* Send a TLS 1.2 session ticket only to a client that asked for one.+  [#575](https://github.com/haskell-tls/hs-tls/pull/575)+* Fall back to a full handshake when a PSK finds a TLS 1.2 session.+  [#576](https://github.com/haskell-tls/hs-tls/pull/576)+* Refuse SCSV or a missing renegotiation_info in secure renegotiation.+  [#566](https://github.com/haskell-tls/hs-tls/pull/566)+* Reject a hybrid key share whose classical part fails to derive.+  [#550](https://github.com/haskell-tls/hs-tls/pull/550)+* Send no SNI for an empty server name, and refuse a malformed or+  invalid server_name.+  [#568](https://github.com/haskell-tls/hs-tls/pull/568)+* Refuse a CertificateVerify algorithm that is not offered or does not+  fit the key with illegal_parameter.+  [#562](https://github.com/haskell-tls/hs-tls/pull/562)+  [#578](https://github.com/haskell-tls/hs-tls/pull/578)+* Accept an empty TLS 1.2 client certificate when the hook does.+  [#552](https://github.com/haskell-tls/hs-tls/pull/552)+* Request EdDSA client certificates with ecdsa_sign in TLS 1.2.+  [#553](https://github.com/haskell-tls/hs-tls/pull/553)+* Accept a ClientHello whose legacy_version is above TLS 1.2.+  [#564](https://github.com/haskell-tls/hs-tls/pull/564)+* Answer malformed or misplaced messages with the alerts the RFCs ask for.+  [#554](https://github.com/haskell-tls/hs-tls/pull/554)+  [#555](https://github.com/haskell-tls/hs-tls/pull/555)+  [#556](https://github.com/haskell-tls/hs-tls/pull/556)+  [#557](https://github.com/haskell-tls/hs-tls/pull/557)+  [#558](https://github.com/haskell-tls/hs-tls/pull/558)+  [#559](https://github.com/haskell-tls/hs-tls/pull/559)+  [#560](https://github.com/haskell-tls/hs-tls/pull/560)+  [#561](https://github.com/haskell-tls/hs-tls/pull/561)+  [#563](https://github.com/haskell-tls/hs-tls/pull/563)+  [#567](https://github.com/haskell-tls/hs-tls/pull/567)+  [#569](https://github.com/haskell-tls/hs-tls/pull/569)+  [#570](https://github.com/haskell-tls/hs-tls/pull/570)+  [#571](https://github.com/haskell-tls/hs-tls/pull/571)+* tls-server: new options for tlsfuzzer, which CI runs weekly.+  [#551](https://github.com/haskell-tls/hs-tls/pull/551)+  [#572](https://github.com/haskell-tls/hs-tls/pull/572)+  [#573](https://github.com/haskell-tls/hs-tls/pull/573)+  [#574](https://github.com/haskell-tls/hs-tls/pull/574)+  [#577](https://github.com/haskell-tls/hs-tls/pull/577)++## Version 2.4.8++* Stop printing traffic secrets and the session secret.+  [#549](https://github.com/haskell-tls/hs-tls/pull/549)++## Version 2.4.7++* Use the one-call AES-GCM and ChaCha20-Poly1305 interfaces of crypton.+  This needs crypton 2.1.1 or later.+  [#548](https://github.com/haskell-tls/hs-tls/pull/548)++## Version 2.4.6++* Accept crypton 2.1.++## Version 2.4.5++* Fix the TLS 1.3 0-RTT session tests racing the NewSessionTicket.+  [#547](https://github.com/haskell-tls/hs-tls/pull/547)+* CI: drop macOS with GHC 9.12.+  [#546](https://github.com/haskell-tls/hs-tls/pull/546)+* CI: retry Hackage downloads, keep the cache when a test fails, and run+  doctest on one job.+  [#545](https://github.com/haskell-tls/hs-tls/pull/545)+* `extensionDecode` returns `Nothing` instead of calling `error`.+  [#544](https://github.com/haskell-tls/hs-tls/pull/544)+* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake.+  [#543](https://github.com/haskell-tls/hs-tls/pull/543)+* Take two timing signals out of the CBC record path.+  [#542](https://github.com/haskell-tls/hs-tls/pull/542)+* Bound the size of a handshake message reassembled from records.+  [#541](https://github.com/haskell-tls/hs-tls/pull/541)+* CI: speed up.+  [#540](https://github.com/haskell-tls/hs-tls/pull/540)+* Limit consecutive TLS 1.3 KeyUpdate messages with the new+  `limitKeyUpdate` parameter.+  [#539](https://github.com/haskell-tls/hs-tls/pull/539)+* Validate the negotiated ALPN protocol.+  [#538](https://github.com/haskell-tls/hs-tls/pull/538)+* Validate the negotiated cipher suite.+  [#537](https://github.com/haskell-tls/hs-tls/pull/537)+* Make the session ticket tests deterministic.+  [#536](https://github.com/haskell-tls/hs-tls/pull/536)++## Version 2.4.4++* Enforce server certificate purpose+  [#534](https://github.com/haskell-tls/hs-tls/pull/534)+* Use dedicated doctest REPL+  [#533](https://github.com/haskell-tls/hs-tls/pull/533)+* Bind early data to ALPN+  [#532](https://github.com/haskell-tls/hs-tls/pull/532)+* Bound certificate decompression+  [#531](https://github.com/haskell-tls/hs-tls/pull/531)+* Fix RecordOverflow race after TLS 1.3 client authentication+  [#530](https://github.com/haskell-tls/hs-tls/pull/530)++## Version 2.4.3++* A server checks clientAuth of ExtendedKeyUsage in a client+  certificate on client authentication.++## Version 2.4.2++* The `Network.TLS.Extra.CipherCBC` module is added.+  [#526](https://github.com/haskell-tls/hs-tls/pull/526)++## Version 2.4.1++* Ensure same `supported_groups` before/after HRR.+* New `clientWantTicket` parameter makes it possible to opt-out of soliciting+  session tickets from servers.++## Version 2.4.0++* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic".++## Version 2.3.1 (deprecated)++* Using ScrubbedBytes for secrets.+* Key echange with ML-KEM.+  [#517](https://github.com/haskell-tls/hs-tls/pull/517)+* Expose get certificate chain function+  [#520](https://github.com/haskell-tls/hs-tls/pull/520)++## Version 2.3.0++* Using "ram" instead of "memory".++## Version 2.2.2++* A new architecture to calculate receiver's transcript hash with wire+  format.+  [#515](https://github.com/haskell-tls/hs-tls/pull/515)+* Enabling compressed certificate on the client side again.++## Version 2.2.1++* Disabling compressed certificate on the client side.+  [#514](https://github.com/haskell-tls/hs-tls/issues/514)++## Version 2.2.0++* Using crypton-asn1-* and time-hourglass.+  [#512](https://github.com/haskell-tls/hs-tls/pull/512)+* Major version up due to re-exports.+ ## Version 2.1.14  * Supporting P384 and P521 curves.@@ -51,14 +205,14 @@   This feature is automatically used if the peer supports it. * More tests with `tlsfuzzer` especially for client authentication   and 0-RTT.-* Implementing a utility funcation, `validateClientCertificate`, for+* Implementing a utility function, `validateClientCertificate`, for   client authentication. * Bug fix for echo back logic of Cookie extension. * More pretty show for the internal `Handshake` structure for debugging.  ## Version 2.1.6 -* Testing with "tlsfuzzer" again. Now don't send an alert agaist to+* Testing with "tlsfuzzer" again. Now don't send an alert against to   peer's alert. Double locking (aka self dead-lock) is fixed. Sending   an alert for known-but-cannot-parse extensions. Other corner cases   are also fixed.@@ -322,7 +476,7 @@ API CHANGES:  - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce`-  function to accomodate resumption scenarios with 0-RTT data.  The function is+  function to accommodate resumption scenarios with 0-RTT data.  The function is   called only on the server side. - Data type `SessionData` is extended with four new fields for TLS version 1.3.   `SessionManager` implementations that serializes/deserializes `SessionData`
Network/TLS.hs view
@@ -11,7 +11,7 @@ -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions. ----- The tipical usage is:+-- The typical usage is: -- -- > socket <- ... -- > ctx <- contextNew socket <params>@@ -46,6 +46,7 @@     clientUseServerNameIndication,     clientWantSessionResume,     clientWantSessionResumeList,+    clientWantTicket,     clientShared,     clientHooks,     clientSupported,@@ -88,6 +89,7 @@     onSuggestALPN,     onCustomFFDHEGroup,     onServerFinished,+    onSelectKeyShareGroups,      -- ** Server hooks     ServerHooks,@@ -100,6 +102,7 @@     onNewHandshake,     onALPNClientSuggest,     onEncryptedExtensionsCreating,+    onSelectKeyShare,     Measurement,     nbHandshakes,     bytesReceived,@@ -119,6 +122,7 @@     supportedFallbackScsv,     supportedEmptyPacket,     supportedGroups,+    supportedGroupsTLS13,      -- ** Debug parameters     DebugParams,@@ -135,6 +139,7 @@     Limit,     defaultLimit,     limitHandshakeFragment,+    limitKeyUpdate,     limitRecordSize,      -- * Shared parameters@@ -236,6 +241,7 @@     unServerRandom,     HandshakeMode13 (..),     getClientCertificateChain,+    getServerCertificateChain,      -- ** Negotiated     getNegotiatedProtocol,@@ -321,10 +327,10 @@ import Network.TLS.Crypto (     DHParams,     DHPublic,-    Group (..),     KxError (..),     supportedNamedGroups,  )+import Network.TLS.Extension import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks import Network.TLS.Imports@@ -361,6 +367,9 @@ --   both cases of full-negotiation and resumption. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain++getServerCertificateChain :: Context -> IO (Maybe CertificateChain)+getServerCertificateChain ctx = usingState_ ctx S.getServerCertificateChain  -- $exceptions --     Since 1.8.0, this library only throws exceptions of type 'TLSException'.
Network/TLS/Compression.hs view
@@ -51,7 +51,7 @@     (==) c1 c2 = compressionID c1 == compressionID c2  -- | intersect a list of ids commonly given by the other side with a list of compression--- the function keeps the list of compression in order, to be able to find quickly the prefered+-- the function keeps the list of compression in order, to be able to find quickly the preferred -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l
Network/TLS/Context.hs view
@@ -8,6 +8,7 @@     Context (..),     Hooks (..),     Established (..),+    PendingRecv (..),     RecordLayer (..),     ctxEOF,     ctxEstablished,@@ -23,6 +24,7 @@     updateMeasure,     withMeasure,     withReadLock,+    tryWithReadLock,     withWriteLock,     withStateLock,     withRWLock,@@ -112,9 +114,9 @@     getTLSCommonParams :: a -> CommonParams     getTLSRole :: a -> Role     doHandshake :: a -> Context -> IO ()-    doHandshakeWith :: a -> Context -> Handshake -> IO ()+    doHandshakeWith :: a -> Context -> HandshakeR -> IO ()     doRequestCertificate :: a -> Context -> IO Bool-    doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO ()+    doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO ()  instance TLSParams ClientParams where     getTLSCommonParams cparams =@@ -265,8 +267,11 @@ --   and use the "tls-exporter" channel binding via 'getTLSExporter'. getTLSUnique :: Context -> IO (Maybe ByteString) getTLSUnique ctx = do-    ver <- liftIO $ usingState_ ctx getVersion-    if ver == TLS12+    -- Nothing rather than error before a version has been negotiated: this+    -- can be called on a context whose handshake has not run, and it already+    -- answers with Maybe.+    mver <- liftIO $ usingState_ ctx getVersionMaybe+    if mver == Just TLS12         then do             mx <- usingState_ ctx getFirstVerifyData             case mx of@@ -278,8 +283,9 @@ --   For TLS 1.2, 'Nothing' is returned. getTLSExporter :: Context -> IO (Maybe ByteString) getTLSExporter ctx = do-    ver <- liftIO $ usingState_ ctx getVersion-    if ver == TLS13+    -- As in 'getTLSUnique'.+    mver <- liftIO $ usingState_ ctx getVersionMaybe+    if mver == Just TLS13         then exporter ctx "EXPORTER-Channel-Binding" "" 32         else return Nothing
Network/TLS/Context/Internal.hs view
@@ -17,6 +17,7 @@     Hooks (..),     Limit (..),     Established (..),+    PendingRecv (..),     PendingRecvAction (..),     RecordLayer (..),     Locks (..),@@ -36,6 +37,7 @@     updateMeasure,     withMeasure,     withReadLock,+    tryWithReadLock,     withWriteLock,     withStateLock,     withRWLock,@@ -65,6 +67,8 @@     defaultTLS13State,     getTLS13State,     modifyTLS13State,+    incrementTLS13KeyUpdateCount,+    resetTLS13KeyUpdateCount,     CipherChoice (..),     makeCipherChoice, @@ -86,8 +90,10 @@ ) where  import Control.Concurrent.MVar-import Control.Exception (throwIO)+import qualified Control.Exception as E import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.IORef import Data.Tuple@@ -166,9 +172,9 @@  data RoleParams = RoleParams     { doHandshake_ :: Context -> IO ()-    , doHandshakeWith_ :: Context -> Handshake -> IO ()+    , doHandshakeWith_ :: Context -> HandshakeR -> IO ()     , doRequestCertificate_ :: Context -> IO Bool-    , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO ()+    , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO ()     }  data Locks = Locks@@ -185,7 +191,7 @@     { cVersion :: Version     , cCipher :: Cipher     , cHash :: Hash-    , cZero :: ByteString+    , cZero :: Secret     }     deriving (Show) @@ -193,15 +199,16 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero   where     h = cipherHash cipher-    zero = B.replicate (hashDigestSize h) 0+    zero = BA.replicate (hashDigestSize h) 0  data TLS13State = TLS13State     { tls13stRecvNST :: Bool -- client+    , tls13stKeyUpdateCount :: Int     , tls13stSentClientCert :: Bool -- client     , tls13stRecvSF :: Bool -- client     , tls13stSentCF :: Bool -- client     , tls13stRecvCF :: Bool -- server-    , tls13stPendingRecvData :: Maybe ByteString -- client+    , tls13stPendingRecv :: PendingRecv -- client     , tls13stPendingSentData :: [ByteString] -> [ByteString] -- client     , tls13stRTT :: Millisecond     , tls13st0RTT :: Bool -- client@@ -209,7 +216,7 @@     , tls13stClientExtensions :: [ExtensionRaw] -- client     , tls13stChoice :: ~CipherChoice -- client     , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client-    -- Actuall session id for TLS 1.2, random value for TLS 1.3+    -- Actual session id for TLS 1.2, random value for TLS 1.3     , tls13stSession :: Session     , tls13stSentExtensions :: [ExtensionID]     }@@ -218,11 +225,12 @@ defaultTLS13State =     TLS13State         { tls13stRecvNST = False+        , tls13stKeyUpdateCount = 0         , tls13stSentClientCert = False         , tls13stRecvSF = False         , tls13stSentCF = False         , tls13stRecvCF = False-        , tls13stPendingRecvData = Nothing+        , tls13stPendingRecv = NoPendingRecv         , tls13stPendingSentData = id         , tls13stRTT = 0         , tls13st0RTT = False@@ -240,6 +248,16 @@ modifyTLS13State :: Context -> (TLS13State -> TLS13State) -> IO () modifyTLS13State Context{..} f = atomicModifyIORef' ctxTLS13State $ \st -> (f st, ()) +incrementTLS13KeyUpdateCount :: Context -> IO Int+incrementTLS13KeyUpdateCount Context{..} =+    atomicModifyIORef' ctxTLS13State $ \st ->+        let count = tls13stKeyUpdateCount st + 1+         in (st{tls13stKeyUpdateCount = count}, count)++resetTLS13KeyUpdateCount :: Context -> IO ()+resetTLS13KeyUpdateCount ctx =+    modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateCount = 0}+ data HandshakeSync     = HandshakeSync         (Context -> ClientState -> IO ())@@ -269,13 +287,24 @@     | Established     deriving (Eq, Show) +-- | Outcome of a read that was started on behalf of a caller who is no longer+-- waiting for it, held until the next receive hands it over.  Reads cannot be+-- abandoned once started -- see 'Network.TLS.Core.handshake' -- so a reader that+-- outlives its caller leaves its result here instead.+data PendingRecv+    = NoPendingRecv+    | PendingRecvData ByteString+    | PendingRecvError E.SomeException+ data PendingRecvAction     = -- | simple pending action. The first 'Bool' is necessity of alignment.-      -- The second bool is update transcript hash.-      PendingRecvAction Bool Bool (Handshake13 -> IO ())+      PendingRecvAction Bool (Handshake13 -> IO ())+    | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ())     | -- | pending action taking transcript hash up to preceding message       --   The first 'Bool' is necessity of alignment.-      PendingRecvActionHash Bool (TranscriptHash -> Handshake13 -> IO ())+      PendingRecvActionHash+        Bool+        (TranscriptHash -> Handshake13 -> IO ())  updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx)@@ -322,7 +351,7 @@                         { infoVersion = v                         , infoCipher = c                         , infoCompression = comp-                        , infoMainSecret = ms+                        , infoMainSecret = convert <$> ms                         , infoExtendedMainSecret = ems                         , infoClientRandom = cr                         , infoServerRandom = sr@@ -363,7 +392,7 @@ withLog ctx f = ctxWithHooks ctx (f . hookLogging)  throwCore :: MonadIO m => TLSError -> m a-throwCore = liftIO . throwIO . Uncontextualized+throwCore = liftIO . E.throwIO . Uncontextualized  failOnEitherError :: MonadIO m => m (Either TLSError a) -> m a failOnEitherError f = do@@ -383,7 +412,7 @@  usingHState :: MonadIO m => Context -> HandshakeM a -> m a usingHState ctx f = liftIO $ modifyMVar (ctxHandshakeState ctx) $ \case-    Nothing -> liftIO $ throwIO MissingHandshake+    Nothing -> liftIO $ E.throwIO MissingHandshake     Just st -> return $ swap (Just <$> runHandshake st f)  getHState :: MonadIO m => Context -> m (Maybe HandshakeState)@@ -445,6 +474,26 @@  withReadLock :: Context -> IO a -> IO a withReadLock ctx f = withMVar (lockRead $ ctxLocks ctx) (const f)++-- | Like 'withReadLock', but returns 'Nothing' immediately instead of waiting+-- when another thread already holds the read lock.+--+-- The read lock is what keeps a single thread reading the connection at a time.+-- Records arrive length-prefixed, so two threads reading in parallel would each+-- take a piece of whatever record the other was in the middle of, and neither+-- would end up with a usable message.+--+-- Use this instead of 'withReadLock' when the read is optional and skipping it+-- is better than waiting for the current reader, which may hold the lock for+-- arbitrarily long.  'bye' is the only such caller; see the note there.+tryWithReadLock :: Context -> IO a -> IO (Maybe a)+tryWithReadLock ctx f = E.bracket acquire release $ \mlock -> case mlock of+    Nothing -> return Nothing+    Just _ -> Just <$> f+  where+    lock = lockRead $ ctxLocks ctx+    acquire = tryTakeMVar lock+    release = mapM_ (putMVar lock)  withWriteLock :: Context -> IO a -> IO a withWriteLock ctx f = withMVar (lockWrite $ ctxLocks ctx) (const f)
Network/TLS/Core.hs view
@@ -27,6 +27,8 @@     requestCertificate, ) where +import Control.Concurrent (forkIO)+import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.State.Strict import qualified Data.ByteString as B@@ -36,6 +38,10 @@ import System.Timeout  import Network.TLS.Context+import Network.TLS.Context.Internal (+    incrementTLS13KeyUpdateCount,+    resetTLS13KeyUpdateCount,+ ) import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common@@ -72,11 +78,39 @@         sentClientCert <- tls13stSentClientCert <$> getTLS13State ctx         when (role == ClientRole && tls13 && sentClientCert) $ do             rtt <- getRTT ctx-            -- This 'timeout' should work.-            mdat <- timeout rtt $ recvData13 ctx-            case mdat of-                Nothing -> return ()-                Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat}+            -- We are only willing to wait 'rtt' for the alert, but a receive+            -- must not be abandoned once it has started.  Records are read+            -- length-prefixed and the record layer keeps no receive buffer, so+            -- an aborted receive loses the bytes it has already taken off the+            -- transport and leaves the stream positioned inside a record.+            -- Every later read is then misframed, and the connection is dead+            -- with a spurious protocol error.+            --+            -- So the receive runs in its own thread and we stop waiting for it+            -- rather than interrupting it.  It holds the read lock, which keeps+            -- it the only reader and makes the next receive wait for it to+            -- finish; its outcome is left in 'tls13stPendingRecv' for that+            -- receive to pick up.+            done <- newEmptyMVar+            void $ forkIO $ withReadLock ctx $ do+                r <- E.try $ recvData13 ctx+                modifyTLS13State ctx $ \st ->+                    st+                        { tls13stPendingRecv = case r of+                            Right dat -> PendingRecvData dat+                            Left err -> PendingRecvError err+                        }+                putMVar done ()+            arrived <- timeout rtt $ takeMVar done+            -- Still report the authentication failure from 'handshake' itself+            -- whenever it did arrive in time.+            when (isJust arrived) $ do+                pending <- tls13stPendingRecv <$> getTLS13State ctx+                case pending of+                    PendingRecvError err -> do+                        modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv}+                        E.throwIO err+                    _ -> return ()  rttFactor :: Int rttFactor = 3@@ -118,7 +152,7 @@                 recvNST <- chk                 unless recvNST $ do                     rtt <- getRTT ctx-                    void $ timeout rtt $ recvHS13 ctx chk+                    tryRecvHS13 rtt chk             else do                 -- receiving Client Finished                 let chk = tls13stRecvCF <$> getTLS13State ctx@@ -127,8 +161,28 @@                     -- no chance to measure RTT before receiving CF                     -- fixme: 1sec is good enough?                     let rtt = 1000000-                    void $ timeout rtt $ recvHS13 ctx chk+                    tryRecvHS13 rtt chk     bye_ ctx+  where+    -- Receiving these messages only improves the chances of a later session+    -- resumption, so giving up on them costs nothing important.  We give up in+    -- two different situations, for two different reasons.+    --+    -- First, we need the read lock, because only one thread at a time may read+    -- the connection, but we take it only if it happens to be free.  Another+    -- thread can be sitting in 'recvData' waiting for data that never arrives,+    -- or the receive that 'handshake' starts can still be running, and either+    -- holds the read lock for as long as it lasts.  Waiting for the lock would+    -- therefore hang 'bye', and closing a connection that a reader is stuck on+    -- is exactly what 'bye' is for, so we skip the receive in that case.+    --+    -- Second, if we do get the lock, we wait 'rtt' for the message and then+    -- abandon the receive.  Abandoning it can stop the connection part way+    -- through a record, after which nothing can be read from it again -- which+    -- is acceptable only because we are closing the connection here anyway.+    tryRecvHS13 :: Int -> IO Bool -> IO ()+    tryRecvHS13 rtt chk =+        void $ tryWithReadLock ctx $ timeout rtt $ recvHS13 ctx chk  bye_ :: MonadIO m => Context -> m () bye_ ctx = liftIO $ do@@ -188,7 +242,7 @@         -- All chunks are protected with the same write lock because we don't         -- want to interleave writes from other threads in the middle of our         -- possibly large write.-        mlen <- getPeerRecordLimit ctx -- plaintext, dont' adjust for TLS 1.3+        mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3         mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend)  -- | Get data out of Data packet, and automatically renegotiate if a Handshake@@ -212,10 +266,10 @@     pkt <- recvPacket12 ctx     either (onError terminate12) process pkt   where-    process (Handshake [ch@ClientHello{}]) =-        handshakeWith ctx ch >> recvData12 ctx-    process (Handshake [hr@HelloRequest]) =-        handshakeWith ctx hr >> recvData12 ctx+    process (Handshake [ch@ClientHello{}] [b]) =+        handshakeWith ctx (ch, b) >> recvData12 ctx+    process (Handshake [hr@HelloRequest] [b]) =+        handshakeWith ctx (hr, b) >> recvData12 ctx     -- UserCanceled should be followed by a close_notify.     -- fixme: is it safe to call recvData12?     process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty@@ -240,15 +294,20 @@  recvData13 :: Context -> IO ByteString recvData13 ctx = do-    mdat <- tls13stPendingRecvData <$> getTLS13State ctx-    case mdat of-        Nothing -> do+    pending <- tls13stPendingRecv <$> getTLS13State ctx+    case pending of+        NoPendingRecv -> do             pkt <- recvPacket13 ctx             either (onError (terminate13 ctx)) process pkt-        Just dat -> do-            modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Nothing}+        PendingRecvData dat -> do+            clearPending             return dat+        PendingRecvError err -> do+            clearPending+            E.throwIO err   where+    clearPending = modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv}+     -- UserCanceled MUST be followed by a CloseNotify.     process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty     process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty@@ -260,8 +319,8 @@                 ("received fatal error: " ++ show desc)                 (Error_Protocol "remote side fatal error" desc)             )-    process (Handshake13 hs) = do-        loopHandshake13 hs+    process (Handshake13 hs bs) = do+        loopHandshake13 $ zip hs bs         recvData13 ctx     -- when receiving empty appdata, we just retry to get some data.     process (AppData13 "") = recvData13 ctx@@ -283,7 +342,7 @@                 | otherwise -> do                     let reason = "early data deprotect overflow"                     terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason-            Established -> return x+            Established -> resetTLS13KeyUpdateCount ctx >> return x             _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage     process ChangeCipherSpec13 = do         established <- ctxEstablished ctx@@ -299,7 +358,7 @@     loopHandshake13 [] = return ()     -- fixme: some implementations send multiple NST at the same time.     -- Only the first one is used at this moment.-    loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do+    loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do         role <- usingState_ ctx S.getRole         unless (role == ClientRole) $ do             let reason = "Session ticket is allowed for client only"@@ -328,16 +387,16 @@             let ticket' = B.copy ticket             void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata             modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}-        loopHandshake13 hs-    loopHandshake13 (KeyUpdate13 mode : hs) = do-        let multipleKeyUpdate = any isKeyUpdate13 hs+        loopHandshake13 hbs+    loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do+        let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs         when multipleKeyUpdate $ do             let reason = "Multiple KeyUpdate is not allowed in one record"             terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason         when (ctxQUICMode ctx) $ do             let reason = "KeyUpdate is not allowed for QUIC"             terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason-        checkAlignment ctx hs+        checkAlignment ctx         established <- ctxEstablished ctx         -- Though RFC 8446 Sec 4.6.3 does not clearly says,         -- unidirectional key update is legal.@@ -345,21 +404,28 @@         -- to key update (update_requested) which we sent.         if established == Established             then do+                case limitKeyUpdate $ sharedLimit $ ctxShared ctx of+                    Just limit | limit > 0 -> do+                        count <- incrementTLS13KeyUpdateCount ctx+                        when (count > limit) $ do+                            let reason = "too many consecutive KeyUpdate messages"+                            terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+                    _ -> return ()                 keyUpdate ctx getRxRecordState setRxRecordState                 -- Write lock wraps both actions because we don't want another                 -- packet to be sent by another thread before the Tx state is                 -- updated.                 when (mode == UpdateRequested) $ withWriteLock ctx $ do-                    sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+                    sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] []                     keyUpdate ctx getTxRecordState setTxRecordState-                loopHandshake13 hs+                loopHandshake13 hbs             else do                 let reason = "received key update before established"                 terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason     -- Client only-    loopHandshake13 (h@CertRequest13{} : hs) =-        postHandshakeAuthWith ctx h >> loopHandshake13 hs-    loopHandshake13 (h : hs) = do+    loopHandshake13 (hb@(CertRequest13{}, _) : hbs) =+        postHandshakeAuthWith ctx hb >> loopHandshake13 hbs+    loopHandshake13 (hb@(h, _) : hbs) = do         rtt0 <- tls13st0RTT <$> getTLS13State ctx         when rtt0 $ case h of             ServerHello13 SH{..} ->@@ -368,8 +434,8 @@                     let reason = "HRR is not allowed for 0-RTT"                     terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason             _ -> return ()-        cont <- popAction ctx h hs-        when cont $ loopHandshake13 hs+        cont <- popAction ctx hb+        when cont $ loopHandshake13 hbs  recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do@@ -380,8 +446,8 @@     -- UserCanceled MUST be followed by a CloseNotify.     process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx     process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx-    process (Handshake13 hs) = do-        loopHandshake13 hs+    process (Handshake13 hs bs) = do+        loopHandshake13 $ zip hs bs         stop <- breakLoop         unless stop $ recvHS13 ctx breakLoop     process _ = recvHS13 ctx breakLoop@@ -389,7 +455,7 @@     loopHandshake13 [] = return ()     -- fixme: some implementations send multiple NST at the same time.     -- Only the first one is used at this moment.-    loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do+    loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do         role <- usingState_ ctx S.getRole         unless (role == ClientRole) $ do             let reason = "Session ticket is allowed for client only"@@ -415,17 +481,17 @@             let ticket' = B.copy ticket             void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata             modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True}-        loopHandshake13 hs-    loopHandshake13 (h : hs) = do-        cont <- popAction ctx h hs-        when cont $ loopHandshake13 hs+        loopHandshake13 hbs+    loopHandshake13 (hb : hbs) = do+        cont <- popAction ctx hb+        when cont $ loopHandshake13 hbs  terminate13     :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool-popAction ctx h hs = do+popAction :: Context -> Handshake13R -> IO Bool+popAction ctx hb@(h, _b) = do     mPendingRecvAction <- popPendingRecvAction ctx     case mPendingRecvAction of         Nothing -> return False@@ -435,14 +501,17 @@             withWriteLock ctx $                 handleException ctx $ do                     case action of-                        PendingRecvAction needAligned update pa -> do-                            when needAligned $ checkAlignment ctx hs-                            when update $ void $ updateTranscriptHash13 ctx h+                        PendingRecvAction needAligned pa -> do+                            when needAligned $ checkAlignment ctx+                            updateTranscriptHash13 ctx hb                             pa h+                        PendingRecvActionSelfUpdate needAligned pa -> do+                            when needAligned $ checkAlignment ctx+                            pa hb                         PendingRecvActionHash needAligned pa -> do-                            when needAligned $ checkAlignment ctx hs+                            when needAligned $ checkAlignment ctx                             d <- transcriptHash ctx "Pending action"-                            void $ updateTranscriptHash13 ctx h+                            updateTranscriptHash13 ctx hb                             pa d h                     -- Client: after receiving SH, app data is coming.                     -- this loop tries to receive it.@@ -451,8 +520,8 @@                     sendCFifNecessary ctx             return True -checkAlignment :: Context -> [Handshake13] -> IO ()-checkAlignment ctx _hs = do+checkAlignment :: Context -> IO ()+checkAlignment ctx = do     complete <- isRecvComplete ctx     unless complete $ do         let reason = "received message not aligned with record boundary"
Network/TLS/Crypto.hs view
@@ -7,6 +7,7 @@     HashCtx,     hashInit,     hashUpdate,+    hashUpdates,     hashUpdateSSL,     hashFinal,     module Network.TLS.Crypto.DH,@@ -60,7 +61,8 @@ import Data.ASN1.BinaryEncoding (BER (..), DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Proxy import Data.X509 (@@ -77,6 +79,8 @@ import Network.TLS.Crypto.Types import Network.TLS.Imports +----------------------------------------------------------------+ {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-}@@ -160,9 +164,9 @@     HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1)  hashFinal :: HashCtx -> ByteString-hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h+hashFinal (HashContext (ContextSimple h)) = convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) =-    B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)]+    B.concat [convert (H.hashFinalize md5Ctx), convert (H.hashFinalize sha1Ctx)]  data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5     deriving (Show, Eq)@@ -179,20 +183,14 @@  type HashCtx = HashContext -hash :: Hash -> ByteString -> ByteString-hash MD5 b = B.convert . (H.hash :: ByteString -> H.Digest H.MD5) $ b-hash SHA1 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA1) $ b-hash SHA224 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA224) $ b-hash SHA256 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA256) $ b-hash SHA384 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA384) $ b-hash SHA512 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA512) $ b-hash SHA1_MD5 b =-    B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)]-  where-    sha1Hash :: ByteString -> H.Digest H.SHA1-    sha1Hash = H.hash-    md5Hash :: ByteString -> H.Digest H.MD5-    md5Hash = H.hash+hash :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba+hash MD5 b = convert (H.hash b :: H.Digest H.MD5)+hash SHA1 b = convert (H.hash b :: H.Digest H.SHA1)+hash SHA224 b = convert (H.hash b :: H.Digest H.SHA224)+hash SHA256 b = convert (H.hash b :: H.Digest H.SHA256)+hash SHA384 b = convert (H.hash b :: H.Digest H.SHA384)+hash SHA512 b = convert (H.hash b :: H.Digest H.SHA512)+hash SHA1_MD5 b = BA.concat [hash MD5 b, hash SHA1 b]  hashName :: Hash -> String hashName = show@@ -223,12 +221,12 @@ generalizeRSAError (Right x) = Right x  kxEncrypt-    :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)+    :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported)  kxDecrypt-    :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)+    :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) @@ -365,9 +363,9 @@             Just sign -> Right (ECDSA.signatureToIntegers prx sign)     unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg =-    return $ Right $ B.convert $ Ed25519.sign pk pub msg+    return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =-    return $ Right $ B.convert $ Ed448.sign pk pub msg+    return $ Right $ convert $ Ed448.sign pk pub msg kxSign _ _ _ _ =     return (Left KxUnsupported)
Network/TLS/Crypto/DH.hs view
@@ -21,14 +21,15 @@  import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH-import qualified Data.ByteArray as B+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA  import Network.TLS.RNG  type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params-type DHKey = DH.SharedKey+type DHKey = ScrubbedBytes  dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber@@ -46,12 +47,12 @@     return (priv, pub)  dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey-dhGetShared params priv pub =-    stripLeadingZeros (DH.getShared params priv pub)+dhGetShared params priv pub = stripLeadingZeros sec   where+    DH.SharedKey sec = DH.getShared params priv pub     -- strips leading zeros from the result of DH.getShared, as required     -- for DH(E) pre-main secret in SSL/TLS before version 1.3.-    stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)+    stripLeadingZeros sb = snd $ BA.span (== 0) sb  -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.
Network/TLS/Crypto/IES.hs view
@@ -1,4 +1,5 @@ -- | (Elliptic Curve) Integrated Encryption Scheme+--   KEM(Key Encapsulation Mechanism) based APIs -- -- Module      : Network.TLS.Crypto.IES -- License     : BSD-style@@ -6,16 +7,19 @@ -- Stability   : experimental -- Portability : unknown module Network.TLS.Crypto.IES (-    GroupPublic,+    GroupPublicA,+    GroupPublicB,     GroupPrivate,     GroupKey,      -- * Group methods     groupGenerateKeyPair,-    groupGetPubShared,-    groupGetShared,-    encodeGroupPublic,-    decodeGroupPublic,+    groupEncapsulate,+    groupDecapsulate,+    groupEncodePublicA,+    groupDecodePublicA,+    groupEncodePublicB,+    groupDecodePublicB,      -- * Compatibility with 'Network.TLS.Crypto.DH'     dhParamsForGroup,@@ -24,12 +28,16 @@ ) where  import Control.Arrow-import Crypto.ECC+import Crypto.ECC as ECC import Crypto.Error import Crypto.Number.Generate-import Crypto.PubKey.DH hiding (generateParams)+import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..))+import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES-import qualified Data.ByteArray as B+import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768)+import qualified Crypto.PubKey.ML_KEM as ML+import Data.ByteArray (ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import Data.Proxy  import Network.TLS.Crypto.Types@@ -38,6 +46,7 @@ import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) +{- FOURMOLU_DISABLE -} data GroupPrivate     = GroupPri_P256 (Scalar Curve_P256R1)     | GroupPri_P384 (Scalar Curve_P384R1)@@ -49,23 +58,59 @@     | GroupPri_FFDHE4096 PrivateNumber     | GroupPri_FFDHE6144 PrivateNumber     | GroupPri_FFDHE8192 PrivateNumber+    | GroupPri_MLKEM512       (ML.DecapsulationKey ML_KEM_512)+    | GroupPri_MLKEM768       (ML.DecapsulationKey ML_KEM_768)+    | GroupPri_MLKEM1024      (ML.DecapsulationKey ML_KEM_1024)+    | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey ML_KEM_768)+    | GroupPri_P256MLKEM768   (Scalar Curve_P256R1, ML.DecapsulationKey ML_KEM_768)+    | GroupPri_P384MLKEM1024  (Scalar Curve_P384R1, ML.DecapsulationKey ML_KEM_1024)     deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -data GroupPublic-    = GroupPub_P256 (Point Curve_P256R1)-    | GroupPub_P384 (Point Curve_P384R1)-    | GroupPub_P521 (Point Curve_P521R1)-    | GroupPub_X255 (Point Curve_X25519)-    | GroupPub_X448 (Point Curve_X448)-    | GroupPub_FFDHE2048 PublicNumber-    | GroupPub_FFDHE3072 PublicNumber-    | GroupPub_FFDHE4096 PublicNumber-    | GroupPub_FFDHE6144 PublicNumber-    | GroupPub_FFDHE8192 PublicNumber+{- FOURMOLU_DISABLE -}+data GroupPublicA+    = GroupPubA_P256 (Point Curve_P256R1)+    | GroupPubA_P384 (Point Curve_P384R1)+    | GroupPubA_P521 (Point Curve_P521R1)+    | GroupPubA_X255 (Point Curve_X25519)+    | GroupPubA_X448 (Point Curve_X448)+    | GroupPubA_FFDHE2048 PublicNumber+    | GroupPubA_FFDHE3072 PublicNumber+    | GroupPubA_FFDHE4096 PublicNumber+    | GroupPubA_FFDHE6144 PublicNumber+    | GroupPubA_FFDHE8192 PublicNumber+    | GroupPubA_MLKEM512       (ML.EncapsulationKey ML_KEM_512)+    | GroupPubA_MLKEM768       (ML.EncapsulationKey ML_KEM_768)+    | GroupPubA_MLKEM1024      (ML.EncapsulationKey ML_KEM_1024)+    | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey ML_KEM_768)+    | GroupPubA_P256MLKEM768   (Point Curve_P256R1, ML.EncapsulationKey ML_KEM_768)+    | GroupPubA_P384MLKEM1024  (Point Curve_P384R1, ML.EncapsulationKey ML_KEM_1024)     deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -type GroupKey = SharedSecret+{- FOURMOLU_DISABLE -}+data GroupPublicB+    = GroupPubB_P256 (Point Curve_P256R1)+    | GroupPubB_P384 (Point Curve_P384R1)+    | GroupPubB_P521 (Point Curve_P521R1)+    | GroupPubB_X255 (Point Curve_X25519)+    | GroupPubB_X448 (Point Curve_X448)+    | GroupPubB_FFDHE2048 PublicNumber+    | GroupPubB_FFDHE3072 PublicNumber+    | GroupPubB_FFDHE4096 PublicNumber+    | GroupPubB_FFDHE6144 PublicNumber+    | GroupPubB_FFDHE8192 PublicNumber+    | GroupPubB_MLKEM512       (ML.Ciphertext ML_KEM_512)+    | GroupPubB_MLKEM768       (ML.Ciphertext ML_KEM_768)+    | GroupPubB_MLKEM1024      (ML.Ciphertext ML_KEM_1024)+    | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext ML_KEM_768)+    | GroupPubB_P256MLKEM768   (Point Curve_P256R1, ML.Ciphertext ML_KEM_768)+    | GroupPubB_P384MLKEM1024  (Point Curve_P384R1, ML.Ciphertext ML_KEM_1024)+    deriving (Eq, Show)+{- FOURMOLU_ENABLE -} +type GroupKey = ScrubbedBytes+ p256 :: Proxy Curve_P256R1 p256 = Proxy @@ -81,7 +126,16 @@ x448 :: Proxy Curve_X448 x448 = Proxy -dhParamsForGroup :: Group -> Maybe Params+mlkem512 :: Proxy ML_KEM_512+mlkem512 = Proxy++mlkem768 :: Proxy ML_KEM_768+mlkem768 = Proxy++mlkem1024 :: Proxy ML_KEM_1024+mlkem1024 = Proxy++dhParamsForGroup :: Group -> Maybe DH.Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096@@ -89,26 +143,47 @@ dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic)+groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA) groupGenerateKeyPair P256 =-    (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256+    (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 =-    (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384+    (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 =-    (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521+    (GroupPri_P521, GroupPubA_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 =-    (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519+    (GroupPri_X255, GroupPubA_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 =-    (GroupPri_X448, GroupPub_X448) `fs` curveGenerateKeyPair x448-groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048-groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072-groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096-groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144-groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192+    (GroupPri_X448, GroupPubA_X448) `fs` curveGenerateKeyPair x448+groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPubA_FFDHE2048+groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPubA_FFDHE3072+groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPubA_FFDHE4096+groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144+groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192+groupGenerateKeyPair MLKEM512 = do+    (e, d) <- ML.generate mlkem512+    return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e)+groupGenerateKeyPair MLKEM768 = do+    (e, d) <- ML.generate mlkem768+    return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e)+groupGenerateKeyPair MLKEM1024 = do+    (e, d) <- ML.generate mlkem1024+    return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e)+groupGenerateKeyPair X25519MLKEM768 = do+    (d1, e1) <- fs' $ curveGenerateKeyPair x25519+    (e2, d2) <- ML.generate mlkem768+    return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2))+groupGenerateKeyPair P256MLKEM768 = do+    (d1, e1) <- fs' $ curveGenerateKeyPair p256+    (e2, d2) <- ML.generate mlkem768+    return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2))+groupGenerateKeyPair P384MLKEM1024 = do+    (d1, e1) <- fs' $ curveGenerateKeyPair p384+    (e2, d2) <- ML.generate mlkem1024+    return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair"  dhGroupGenerateKeyPair-    :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber)+    :: MonadRandom r => Group -> r (DH.Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096)@@ -116,148 +191,332 @@ dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) -addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b)+addParams :: Functor f => DH.Params -> f (a, b) -> f (DH.Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b)  fs     :: MonadRandom r-    => (Scalar a -> GroupPrivate, Point a -> GroupPublic)+    => (Scalar a -> GroupPrivate, Point a -> GroupPublicA)     -> r (KeyPair a)-    -> r (GroupPrivate, GroupPublic)+    -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do     keypair <- action     let pub = keypairGetPublic keypair         pri = keypairGetPrivate keypair     return (t1 pri, t2 pub) +fs' :: Monad m => m (KeyPair curve) -> m (Scalar curve, Point curve)+fs' action = do+    keypair <- action+    let pub = keypairGetPublic keypair+        pri = keypairGetPrivate keypair+    return (pri, pub)+ gen     :: MonadRandom r-    => Params+    => DH.Params     -> Int     -> (PrivateNumber -> GroupPrivate)-    -> (PublicNumber -> GroupPublic)-    -> r (GroupPrivate, GroupPublic)+    -> (PublicNumber -> GroupPublicA)+    -> r (GroupPrivate, GroupPublicA) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits  gen'     :: MonadRandom r-    => Params+    => DH.Params     -> Int     -> r (PrivateNumber, PublicNumber)-gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared-    :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey))-groupGetPubShared (GroupPub_P256 pub) =-    fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub-groupGetPubShared (GroupPub_P384 pub) =-    fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub-groupGetPubShared (GroupPub_P521 pub) =-    fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub-groupGetPubShared (GroupPub_X255 pub) =-    fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub-groupGetPubShared (GroupPub_X448 pub) =-    fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192+groupEncapsulate+    :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey))+groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub+groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub+groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub+groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub+groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub+groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048+groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072+groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096+groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144+groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192+groupEncapsulate (GroupPubA_MLKEM512 pub) = do+    (sec, ct) <- ML.encapsulate pub+    return $ Just (GroupPubB_MLKEM512 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM768 pub) = do+    (sec, ct) <- ML.encapsulate pub+    return $ Just (GroupPubB_MLKEM768 ct, convert sec)+groupEncapsulate (GroupPubA_MLKEM1024 pub) = do+    (sec, ct) <- ML.encapsulate pub+    return $ Just (GroupPubB_MLKEM1024 ct, convert sec)+-- The classical part of a hybrid can fail as the group alone does: an+-- all-zero X25519 public key decodes, but the shared secret derived from+-- it is rejected.  Nothing is turned into illegal_parameter by the caller.+groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do+    mx <- getECDHPubShared' x25519 e1+    case mx of+        Nothing -> return Nothing+        Just (c1, k1) -> do+            (k2, c2) <- ML.encapsulate e2+            -- Sec 4.1: Specifically, the order of shares in the concatenation+            -- has been reversed.+            return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1)+groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do+    mx <- getECDHPubShared' p256 e1+    case mx of+        Nothing -> return Nothing+        Just (c1, k1) -> do+            (k2, c2) <- ML.encapsulate e2+            return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do+    mx <- getECDHPubShared' p384 e1+    case mx of+        Nothing -> return Nothing+        Just (c1, k1) -> do+            (k2, c2) <- ML.encapsulate e2+            return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2)  dhGroupGetPubShared-    :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))-dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub-dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub-dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub-dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub-dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub+    :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey))+dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub+dhGroupGetPubShared FFDHE3072 pub = getDHPubShared' ffdhe3072 exp3072 pub+dhGroupGetPubShared FFDHE4096 pub = getDHPubShared' ffdhe4096 exp4096 pub+dhGroupGetPubShared FFDHE6144 pub = getDHPubShared' ffdhe6144 exp6144 pub+dhGroupGetPubShared FFDHE8192 pub = getDHPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing -getPubShared+getECDHPubShared+    :: (MonadRandom m, EllipticCurveDH curve)+    => (Point curve -> GroupPublicB)+    -> proxy curve+    -> Point curve+    -> m (Maybe (GroupPublicB, GroupKey))+getECDHPubShared tag proxy pub = do+    mx <- maybeCryptoError <$> deriveEncrypt proxy pub+    case mx of+        Nothing -> return Nothing+        Just (p, ECC.SharedSecret s) -> return $ Just (tag p, s)++getECDHPubShared'+    :: (MonadRandom m, EllipticCurveDH curve)+    => proxy curve+    -> Point curve+    -> m (Maybe (Point curve, GroupKey))+getECDHPubShared' proxy pub = do+    mx <- maybeCryptoError <$> deriveEncrypt proxy pub+    case mx of+        Nothing -> return Nothing+        Just (p, ECC.SharedSecret s) -> return $ Just (p, s)++getDHPubShared     :: MonadRandom r-    => Params+    => DH.Params     -> Int     -> PublicNumber-    -> (PublicNumber -> GroupPublic)-    -> r (Maybe (GroupPublic, GroupKey))-getPubShared params expBits pub pubTag+    -> (PublicNumber -> GroupPublicB)+    -> r (Maybe (GroupPublicB, GroupKey))+getDHPubShared params expBits pub pubTag     | not (valid params pub) = return Nothing     | otherwise = do         mypri <- generatePriv expBits-        let mypub = calculatePublic params mypri-        let SharedKey share = getShared params mypri pub-        return $ Just (pubTag mypub, SharedSecret share)+        let mypub = DH.calculatePublic params mypri+            DH.SharedKey share = DH.getShared params mypri pub+        return $ Just (pubTag mypub, share) -getPubShared'+getDHPubShared'     :: MonadRandom r-    => Params+    => DH.Params     -> Int     -> PublicNumber-    -> r (Maybe (PublicNumber, SharedKey))-getPubShared' params expBits pub+    -> r (Maybe (PublicNumber, GroupKey))+getDHPubShared' params expBits pub     | not (valid params pub) = return Nothing     | otherwise = do         mypri <- generatePriv expBits-        let share = stripLeadingZeros (getShared params mypri pub)-        return $ Just (calculatePublic params mypri, SharedKey share)+        let share = stripLeadingZeros (DH.getShared params mypri pub)+        return $ Just (DH.calculatePublic params mypri, convert share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey-groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri-groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri-groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri-groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri-groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri-groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri-groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri-groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri-groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri-groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri-groupGetShared _ _ = Nothing+unwrap :: SharedSecret -> GroupKey+unwrap (ECC.SharedSecret sec) = sec -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret-calcShared params pub pri-    | valid params pub = Just $ SharedSecret share+groupDecapsulate :: GroupPublicB -> GroupPrivate -> Maybe GroupKey+groupDecapsulate (GroupPubB_P256 pub) (GroupPri_P256 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 pub pri+groupDecapsulate (GroupPubB_P384 pub) (GroupPri_P384 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 pub pri+groupDecapsulate (GroupPubB_P521 pub) (GroupPri_P521 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p521 pub pri+groupDecapsulate (GroupPubB_X255 pub) (GroupPri_X255 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 pub pri+groupDecapsulate (GroupPubB_X448 pub) (GroupPri_X448 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x448 pub pri+groupDecapsulate (GroupPubB_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcDHShared ffdhe2048 pub pri+groupDecapsulate (GroupPubB_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcDHShared ffdhe3072 pub pri+groupDecapsulate (GroupPubB_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcDHShared ffdhe4096 pub pri+groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri+groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri+groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) =+    Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) =+    Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) =+    Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do+    bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1+    let bs2 = convert $ ML.decapsulate s2 p2+    return (bs2 <> bs1)+groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do+    bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1+    let bs2 = convert $ ML.decapsulate s2 p2+    return (bs1 <> bs2)+groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do+    bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1+    let bs2 = convert $ ML.decapsulate s2 p2+    return (bs1 <> bs2)+groupDecapsulate _ _ = Nothing++calcDHShared :: DH.Params -> PublicNumber -> PrivateNumber -> Maybe GroupKey+calcDHShared params pub pri+    | valid params pub = Just $ convert share     | otherwise = Nothing   where-    SharedKey share = getShared params pri pub+    share = DH.getShared params pri pub -encodeGroupPublic :: GroupPublic -> ByteString-encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p-encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p-encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p-encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p-encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p-encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p-encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p-encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p-encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p-encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA :: GroupPublicA -> ByteString+groupEncodePublicA (GroupPubA_P256 p) = encodePoint p256 p+groupEncodePublicA (GroupPubA_P384 p) = encodePoint p384 p+groupEncodePublicA (GroupPubA_P521 p) = encodePoint p521 p+groupEncodePublicA (GroupPubA_X255 p) = encodePoint x25519 p+groupEncodePublicA (GroupPubA_X448 p) = encodePoint x448 p+groupEncodePublicA (GroupPubA_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicA (GroupPubA_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA (GroupPubA_MLKEM512 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM768 p) = ML.encode p+groupEncodePublicA (GroupPubA_MLKEM1024 p) = ML.encode p+groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) =+    ML.encode p2 <> encodePoint x25519 p1+groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) =+    encodePoint p256 p1 <> ML.encode p2+groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) =+    encodePoint p384 p1 <> ML.encode p2 -enc :: Params -> PublicNumber -> ByteString-enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p+groupEncodePublicB :: GroupPublicB -> ByteString+groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p+groupEncodePublicB (GroupPubB_P384 p) = encodePoint p384 p+groupEncodePublicB (GroupPubB_P521 p) = encodePoint p521 p+groupEncodePublicB (GroupPubB_X255 p) = encodePoint x25519 p+groupEncodePublicB (GroupPubB_X448 p) = encodePoint x448 p+groupEncodePublicB (GroupPubB_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicB (GroupPubB_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicB (GroupPubB_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicB (GroupPubB_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicB (GroupPubB_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicB (GroupPubB_MLKEM512 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM768 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM1024 p) = convert p+groupEncodePublicB (GroupPubB_X25519MLKEM768 (p1, p2)) =+    convert p2 <> encodePoint x25519 p1+groupEncodePublicB (GroupPubB_P256MLKEM768 (p1, p2)) =+    encodePoint p256 p1 <> convert p2+groupEncodePublicB (GroupPubB_P384MLKEM1024 (p1, p2)) =+    encodePoint p384 p1 <> convert p2 -decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic-decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs-decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs-decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs-decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs-decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs-decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs-decodeGroupPublic _ _ = error "decodeGroupPublic"+enc :: DH.Params -> PublicNumber -> ByteString+enc params (PublicNumber p) = i2ospOf_ ((DH.params_bits params + 7) `div` 8) p +groupDecodePublicA :: Group -> ByteString -> Either CryptoError GroupPublicA+groupDecodePublicA P256 bs = eitherCryptoError $ GroupPubA_P256 <$> decodePoint p256 bs+groupDecodePublicA P384 bs = eitherCryptoError $ GroupPubA_P384 <$> decodePoint p384 bs+groupDecodePublicA P521 bs = eitherCryptoError $ GroupPubA_P521 <$> decodePoint p521 bs+groupDecodePublicA X25519 bs = eitherCryptoError $ GroupPubA_X255 <$> decodePoint x25519 bs+groupDecodePublicA X448 bs = eitherCryptoError $ GroupPubA_X448 <$> decodePoint x448 bs+groupDecodePublicA FFDHE2048 bs = Right . GroupPubA_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE3072 bs = Right . GroupPubA_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicA MLKEM512 bs = case ML.decode mlkem512 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubA_MLKEM512 p+groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubA_MLKEM768 p+groupDecodePublicA MLKEM1024 bs = case ML.decode mlkem1024 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubA_MLKEM1024 p+groupDecodePublicA X25519MLKEM768 bs =+    let (bs1, bs2) = BA.splitAt 1184 bs+     in case ML.decode mlkem768 bs1 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1)+groupDecodePublicA P256MLKEM768 bs =+    let (bs1, bs2) = BA.splitAt 65 bs+     in case ML.decode mlkem768 bs2 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1)+groupDecodePublicA P384MLKEM1024 bs =+    let (bs1, bs2) = BA.splitAt 97 bs+     in case ML.decode mlkem1024 bs2 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubA_P384MLKEM1024 (p2, p1)+groupDecodePublicA _ _ = error "groupDecodePublicA"++groupDecodePublicB :: Group -> ByteString -> Either CryptoError GroupPublicB+groupDecodePublicB P256 bs = eitherCryptoError $ GroupPubB_P256 <$> decodePoint p256 bs+groupDecodePublicB P384 bs = eitherCryptoError $ GroupPubB_P384 <$> decodePoint p384 bs+groupDecodePublicB P521 bs = eitherCryptoError $ GroupPubB_P521 <$> decodePoint p521 bs+groupDecodePublicB X25519 bs = eitherCryptoError $ GroupPubB_X255 <$> decodePoint x25519 bs+groupDecodePublicB X448 bs = eitherCryptoError $ GroupPubB_X448 <$> decodePoint x448 bs+groupDecodePublicB FFDHE2048 bs = Right . GroupPubB_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE3072 bs = Right . GroupPubB_FFDHE3072 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs+groupDecodePublicB MLKEM512 bs = case ML.decode mlkem512 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubB_MLKEM512 p+groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubB_MLKEM768 p+groupDecodePublicB MLKEM1024 bs = case ML.decode mlkem1024 bs of+    Nothing -> Left CryptoError_PointFormatInvalid+    Just p -> Right $ GroupPubB_MLKEM1024 p+groupDecodePublicB X25519MLKEM768 bs =+    let (bs1, bs2) = BA.splitAt 1088 bs+     in case ML.decode mlkem768 bs1 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1)+groupDecodePublicB P256MLKEM768 bs =+    let (bs1, bs2) = BA.splitAt 65 bs+     in case ML.decode mlkem768 bs2 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1)+groupDecodePublicB P384MLKEM1024 bs =+    let (bs1, bs2) = BA.splitAt 97 bs+     in case ML.decode mlkem1024 bs2 of+            Nothing -> Left CryptoError_PointFormatInvalid+            Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+                Nothing -> Left CryptoError_PointFormatInvalid+                Just p2 -> Right $ GroupPubB_P384MLKEM1024 (p2, p1)+groupDecodePublicB _ _ = error "groupDecodePublicB"+ -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.-valid :: Params -> PublicNumber -> Bool-valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1+valid :: DH.Params -> PublicNumber -> Bool+valid (DH.Params p _ _) (PublicNumber y) = 1 < y && y < p - 1  -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.-stripLeadingZeros :: SharedKey -> B.ScrubbedBytes-stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb+stripLeadingZeros :: DH.SharedKey -> ScrubbedBytes+stripLeadingZeros (DH.SharedKey sb) = snd $ BA.span (== 0) sb  -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber
Network/TLS/Crypto/Types.hs view
@@ -19,11 +19,19 @@         FFDHE3072,         FFDHE4096,         FFDHE6144,-        FFDHE8192+        FFDHE8192,+        MLKEM512,+        MLKEM768,+        MLKEM1024,+        X25519MLKEM768,+        P256MLKEM768,+        P384MLKEM1024     ),     availableFFGroups,     availableECGroups,+    availableHybridGroups,     supportedNamedGroups,+    supportedNamedGroupsTLS13,     KeyExchangeSignatureAlg (..), ) where @@ -55,6 +63,18 @@ pattern FFDHE6144  = Group 259 pattern FFDHE8192 :: Group pattern FFDHE8192  = Group 260+pattern MLKEM512  :: Group+pattern MLKEM512   = Group 512+pattern MLKEM768  :: Group+pattern MLKEM768   = Group 513+pattern MLKEM1024 :: Group+pattern MLKEM1024  = Group 514+pattern X25519MLKEM768 :: Group+pattern X25519MLKEM768  = Group 4588+pattern P256MLKEM768   :: Group+pattern P256MLKEM768    = Group 4587+pattern P384MLKEM1024  :: Group+pattern P384MLKEM1024   = Group 4589  instance Show Group where     show P256      = "P256"@@ -67,6 +87,12 @@     show FFDHE4096 = "FFDHE4096"     show FFDHE6144 = "FFDHE6144"     show FFDHE8192 = "FFDHE8192"+    show MLKEM512  = "MLKEM512"+    show MLKEM768  = "MLKEM768"+    show MLKEM1024 = "MLKEM1024"+    show X25519MLKEM768 = "X25519MLKEM768"+    show P256MLKEM768   = "P256MLKEM768"+    show P384MLKEM1024  = "P384MLKEM1024"     show (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} @@ -76,18 +102,39 @@ availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] +availableHybridGroups :: [Group]+availableHybridGroups = [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]++-- | A list for named groups.  The ordering is for client preference+--   because server preference is not used in our server+--   implementation. supportedNamedGroups :: [Group] supportedNamedGroups =-    [ X25519-    , X448-    , P256-    , FFDHE2048-    , FFDHE3072-    , FFDHE4096-    , P384-    , FFDHE6144-    , FFDHE8192-    , P521+    [ X25519 -- 128 bits security+    , P256 -- 128 bits security+    , P384 -- 192 bits security+    , X448 -- 224 bits security+    , P521 -- 256 bits security+    --    , FFDHE2048 -- 103 bits security+    , FFDHE3072 -- 125 bits security+    , FFDHE4096 -- 150 bits security+    , FFDHE6144 -- 175 bits security+    , FFDHE8192 -- 192 bits security+    , X25519MLKEM768+    , P256MLKEM768+    , P384MLKEM1024+    , -- , MLKEM512+      MLKEM768+    , MLKEM1024+    ]++supportedNamedGroupsTLS13 :: [[Group]]+supportedNamedGroupsTLS13 =+    [ [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]+    , [X25519, P256]+    , [P384, X448, P521]+    , [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192]+    , [MLKEM768, MLKEM1024]     ]  -- Key-exchange signature algorithm, in close relation to ciphers
Network/TLS/Error.hs view
@@ -3,8 +3,7 @@  module Network.TLS.Error where -import Control.Exception (Exception (..))-import Data.Typeable+import qualified Control.Exception as E  import Network.TLS.Imports @@ -34,7 +33,7 @@     | Error_Packet_unexpected String String     | Error_Packet_Parsing String     | Error_TCP_Terminate-    deriving (Eq, Show, Typeable)+    deriving (Eq, Show)  ---------------------------------------------------------------- @@ -61,9 +60,9 @@       --   handshake had occurred.       --   Indicates that this library has been used incorrectly.       MissingHandshake-    deriving (Show, Eq, Typeable)+    deriving (Show, Eq) -instance Exception TLSException+instance E.Exception TLSException  ----------------------------------------------------------------
Network/TLS/Extension.hs view
@@ -428,7 +428,22 @@ -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where     extensionID :: a -> ExtensionID++    -- | Decode an extension's body as it appears in the given message.+    --+    -- 'Nothing' covers both ways this can fail to produce a value: a body+    -- that does not parse, and a message the extension is not defined in.+    -- Both reach the peer the same way, as the decode_error alert that+    -- 'lookupAndDecode' and 'lookupAndDecodeAndDo' raise, which is what+    -- either case warrants.+    --+    -- So the last clause of an instance is @Nothing@, never @error@: the+    -- message type is chosen by this library rather than by the peer, so an+    -- unhandled one would be our own bug -- and turning our bug into an+    -- ErrorCall thrown from pure code, out through the handshake and into+    -- the application, is a worse answer than dropping the one connection.     extensionDecode :: MessageType -> ByteString -> Maybe a+     extensionEncode :: a -> ByteString  data MessageType@@ -438,12 +453,12 @@     | MsgTEncryptedExtensions     | MsgTNewSessionTicket     | MsgTCertificateRequest-    deriving (Eq, Show)+    deriving (Eq, Show, Enum, Bounded)  ------------------------------------------------------------  -- | Server Name extension including the name type and the associated name.--- the associated name decoding is dependant of its name type.+-- the associated name decoding is dependent of its name type. -- name type = 0 : hostname newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq) @@ -466,21 +481,32 @@       where         encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion         encodeNameType (ServerNameOther (nt, opaque)) = putWord8 nt >> putBytes opaque-    extensionDecode MsgTClientHello = decodeServerName+    extensionDecode MsgTClientHello = decodeServerNameList     extensionDecode MsgTServerHello = decodeServerName     extensionDecode MsgTEncryptedExtensions = decodeServerName-    extensionDecode _ = error "extensionDecode: ServerName"+    extensionDecode _ = const Nothing  decodeServerName :: ByteString -> Maybe ServerName decodeServerName "" = Just $ ServerName [] -- dirty hack for servers-decodeServerName bs = runGetMaybe decode bs+decodeServerName bs = decodeServerNameList bs++-- RFC 6066 Section 3: server_name_list<1..2^16-1> of+-- HostName<1..2^16-1>, which leaves no room for an empty extension, an+-- empty list, an empty host name nor trailing data.+decodeServerNameList :: ByteString -> Maybe ServerName+decodeServerNameList = runGetMaybe decode   where     decode = do         len <- fromIntegral <$> getWord16-        ServerName <$> getList len getServerName+        names <- getList len getServerName+        when (null names) $ fail "empty server_name_list"+        r <- remaining+        when (r /= 0) $ fail "trailing data in server_name"+        return $ ServerName names     getServerName = do         ty <- getWord8         snameParsed <- getOpaque16+        when (ty == 0 && B.null snameParsed) $ fail "empty host_name"         let sname = B.copy snameParsed             name = case ty of                 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion@@ -521,7 +547,7 @@     extensionDecode MsgTClientHello = decodeMaxFragmentLength     extensionDecode MsgTServerHello = decodeMaxFragmentLength     extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength-    extensionDecode _ = error "extensionDecode: MaxFragmentLength"+    extensionDecode _ = const Nothing  decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8@@ -542,7 +568,7 @@     extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups     extensionDecode MsgTClientHello = decodeSupportedGroups     extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups-    extensionDecode _ = error "extensionDecode: SupportedGroups"+    extensionDecode _ = const Nothing  decodeSupportedGroups :: ByteString -> Maybe SupportedGroups decodeSupportedGroups =@@ -577,11 +603,14 @@     extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats     extensionDecode MsgTClientHello = decodeEcPointFormatsSupported     extensionDecode MsgTServerHello = decodeEcPointFormatsSupported-    extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"+    extensionDecode _ = const Nothing  decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported-decodeEcPointFormatsSupported =-    runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8)+decodeEcPointFormatsSupported = runGetMaybe $ do+    formats <- getWords8+    -- RFC 8422 Section 5.1.2: ec_point_format_list<1..2^8-1>+    when (null formats) $ fail "empty ec_point_format_list"+    return $ EcPointFormatsSupported $ map EcPointFormat formats  ------------------------------------------------------------ @@ -596,7 +625,7 @@                 >> mapM_ putSignatureHashAlgorithm algs     extensionDecode MsgTClientHello = decodeSignatureAlgorithms     extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms-    extensionDecode _ = error "extensionDecode: SignatureAlgorithms"+    extensionDecode _ = const Nothing  decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms decodeSignatureAlgorithms = runGetMaybe $ do@@ -632,7 +661,7 @@     extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode     extensionDecode MsgTClientHello = decodeHeartBeat     extensionDecode MsgTServerHello = decodeHeartBeat-    extensionDecode _ = error "extensionDecode: HeartBeat"+    extensionDecode _ = const Nothing  decodeHeartBeat :: ByteString -> Maybe HeartBeat decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8@@ -651,16 +680,23 @@     extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation     extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation     extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation-    extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation"+    extensionDecode _ = const Nothing  decodeApplicationLayerProtocolNegotiation     :: ByteString -> Maybe ApplicationLayerProtocolNegotiation decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do     len <- getWord16-    ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN+    protos <- getList (fromIntegral len) getALPN+    -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of+    -- ProtocolName<1..2^8-1>, with nothing after it.+    when (null protos) $ fail "empty protocol_name_list"+    r <- remaining+    when (r /= 0) $ fail "trailing data in application_layer_protocol_negotiation"+    return $ ApplicationLayerProtocolNegotiation protos   where     getALPN = do         alpnParsed <- getOpaque8+        when (B.null alpnParsed) $ fail "empty ProtocolName"         let alpn = B.copy alpnParsed         return (B.length alpn + 1, alpn) @@ -674,7 +710,7 @@     extensionEncode ExtendedMainSecret = B.empty     extensionDecode MsgTClientHello "" = Just ExtendedMainSecret     extensionDecode MsgTServerHello "" = Just ExtendedMainSecret-    extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret"+    extensionDecode _ _ = Nothing  ------------------------------------------------------------ @@ -749,7 +785,7 @@     extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket     extensionDecode MsgTClientHello = decodeSessionTicket     extensionDecode MsgTServerHello = decodeSessionTicket-    extensionDecode _ = error "extensionDecode: SessionTicket"+    extensionDecode _ = const Nothing  decodeSessionTicket :: ByteString -> Maybe SessionTicket decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)@@ -792,7 +828,7 @@                 fromIntegral w16     extensionDecode MsgTClientHello = decodePreSharedKeyClientHello     extensionDecode MsgTServerHello = decodePreSharedKeyServerHello-    extensionDecode _ = error "extensionDecode: PreShareKey"+    extensionDecode _ = const Nothing  decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey decodePreSharedKeyClientHello = runGetMaybe $ do@@ -837,7 +873,7 @@     extensionDecode MsgTNewSessionTicket =         runGetMaybe $             EarlyDataIndication . Just <$> getWord32-    extensionDecode _ = error "extensionDecode: EarlyDataIndication"+    extensionDecode _ = const Nothing  ------------------------------------------------------------ @@ -860,7 +896,7 @@             putBinaryVersion ver     extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello     extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello-    extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"+    extensionDecode _ = const Nothing  decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions decodeSupportedVersionsClientHello = runGetMaybe $ do@@ -888,7 +924,7 @@     extensionID _ = EID_Cookie     extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque     extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)-    extensionDecode _ = error "extensionDecode: Cookie"+    extensionDecode _ = const Nothing  ------------------------------------------------------------ @@ -916,7 +952,7 @@             putWords8 $                 map fromPskKexMode pkms     extensionDecode MsgTClientHello = decodePskKeyExchangeModes-    extensionDecode _ = error "extensionDecode: PskKeyExchangeModes"+    extensionDecode _ = const Nothing  decodePskKeyExchangeModes :: ByteString -> Maybe PskKeyExchangeModes decodePskKeyExchangeModes =@@ -935,7 +971,7 @@             putDNames names     extensionDecode MsgTClientHello = decodeCertificateAuthorities     extensionDecode MsgTCertificateRequest = decodeCertificateAuthorities-    extensionDecode _ = error "extensionDecode: CertificateAuthorities"+    extensionDecode _ = const Nothing  decodeCertificateAuthorities :: ByteString -> Maybe CertificateAuthorities decodeCertificateAuthorities =@@ -949,7 +985,7 @@     extensionID _ = EID_PostHandshakeAuth     extensionEncode _ = B.empty     extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth-    extensionDecode _ = error "extensionDecode: PostHandshakeAuth"+    extensionDecode _ = const Nothing  ------------------------------------------------------------ @@ -964,7 +1000,7 @@                 >> mapM_ putSignatureHashAlgorithm algs     extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert     extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert-    extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert"+    extensionDecode _ = const Nothing  decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert decodeSignatureAlgorithmsCert = runGetMaybe $ do@@ -1021,7 +1057,7 @@     extensionDecode MsgTClientHello = decodeKeyShareClientHello     extensionDecode MsgTServerHello = decodeKeyShareServerHello     extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR-    extensionDecode _ = error "extensionDecode: KeyShare"+    extensionDecode _ = const Nothing  decodeKeyShareClientHello :: ByteString -> Maybe KeyShare decodeKeyShareClientHello = runGetMaybe $ do@@ -1059,7 +1095,7 @@         putWord8 $ fromIntegral (length ids * 2)         mapM_ (putWord16 . fromExtensionID) ids     extensionDecode MsgTClientHello = decodeEchOuterExtensions-    extensionDecode _ = error "extensionDecode: EchOuterExtensions"+    extensionDecode _ = const Nothing  decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions decodeEchOuterExtensions = runGetMaybe $ do@@ -1120,7 +1156,7 @@     extensionDecode MsgTClientHello = decodeECHClientHello     extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions     extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest-    extensionDecode _ = error "extensionDecode: EncryptedClientHello"+    extensionDecode _ = const Nothing  decodeECH :: ByteString -> Maybe EncryptedClientHello decodeECH bs =@@ -1172,4 +1208,4 @@         opaque <- getOpaque8         let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque         return $ SecureRenegotiation cvd svd-    extensionDecode _ = error "extensionDecode: SecureRenegotiation"+    extensionDecode _ = const Nothing
Network/TLS/Extra/Cipher.hs view
@@ -70,11 +70,12 @@ ) where  import Crypto.Cipher.AES-import qualified Crypto.Cipher.ChaChaPoly1305 as ChaChaPoly1305+import qualified Crypto.Cipher.AES.GCM as GCM+import qualified Crypto.Cipher.ChaCha.Poly1305 as ChaChaOne import Crypto.Cipher.Types hiding (Cipher, cipherName) import Crypto.Error-import qualified Crypto.MAC.Poly1305 as Poly1305 import Crypto.System.CPU+import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.Tuple (swap) @@ -619,20 +620,40 @@              in simpleDecrypt aeadIni ad d 8         ) +-- The AES-GCM and ChaCha20-Poly1305 ciphers go through the one-call+-- interfaces crypton added for this, not the general AEAD one.  Two things+-- are saved on every record.+--+-- The state the key alone determines -- the AES key schedule and the table of+-- multiples of H -- was rebuilt for each record by aeadInit; newContext+-- builds it once, here, where the key is fixed.+--+-- And the general interface reaches its cipher through AEADModeImpl, whose+-- fields are @forall ba. ByteArray ba => ...@, so a dictionary is passed at+-- every call and no pragma can remove it.+--+-- Measured in C on an idle Haswell, against what this did before: 64-byte+-- record 0.169 -> 0.047 microseconds, 1400-byte 0.501 -> 0.301, 16 KiB+-- 3.285 -> 3.207.  It is a fixed cost that goes, so it is most of a small+-- record and little of a full one.+aesgcm :: BulkDirection -> BulkKey -> BulkAEAD+aesgcm BulkEncrypt key =+    let ctx = noFail (GCM.newContext key)+     in \nonce d ad ->+            let sealed = GCM.encrypt ctx nonce ad d 16+                (out, tag) = B.splitAt (B.length sealed - 16) sealed+             in (out, AuthTag (convert tag))+aesgcm BulkDecrypt key =+    let ctx = noFail (GCM.newContext key)+     in \nonce d ad -> GCM.decryptWithTag ctx nonce ad d 16+ aes128gcm :: BulkDirection -> BulkKey -> BulkAEAD-aes128gcm BulkEncrypt key =-    let ctx = noFail (cipherInit key) :: AES128-     in ( \nonce d ad ->-            let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)-             in swap $ aeadSimpleEncrypt aeadIni ad d 16-        )-aes128gcm BulkDecrypt key =-    let ctx = noFail (cipherInit key) :: AES128-     in ( \nonce d ad ->-            let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)-             in simpleDecrypt aeadIni ad d 16-        )+aes128gcm = aesgcm +aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD+aes256gcm = aesgcm++ aes256ccm :: BulkDirection -> BulkKey -> BulkAEAD aes256ccm BulkEncrypt key =     let ctx = noFail (cipherInit key) :: AES256@@ -665,20 +686,6 @@              in simpleDecrypt aeadIni ad d 8         ) -aes256gcm :: BulkDirection -> BulkKey -> BulkAEAD-aes256gcm BulkEncrypt key =-    let ctx = noFail (cipherInit key) :: AES256-     in ( \nonce d ad ->-            let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)-             in swap $ aeadSimpleEncrypt aeadIni ad d 16-        )-aes256gcm BulkDecrypt key =-    let ctx = noFail (cipherInit key) :: AES256-     in ( \nonce d ad ->-            let aeadIni = noFail (aeadInit AEAD_GCM ctx nonce)-             in simpleDecrypt aeadIni ad d 16-        )- simpleDecrypt     :: AEAD cipher -> ByteString -> ByteString -> Int -> (ByteString, AuthTag) simpleDecrypt aeadIni header input taglen = (output, tag)@@ -690,23 +697,23 @@ noFail :: CryptoFailable a -> a noFail = throwCryptoError +-- The one-call interface here too, and for the same two reasons as the AES+-- ciphers above: the step-at-a-time Crypto.Cipher.ChaChaPoly1305 is eight+-- foreign calls and the allocations between them for a message that arrived+-- whole, and the general AEAD interface passes a dictionary a call.+--+-- Measured through the Haskell interface on an Apple M4: 100 bytes 0.97 ->+-- 0.415 microseconds, 1400 bytes 2.89 -> 2.36. chacha20poly1305 :: BulkDirection -> BulkKey -> BulkAEAD-chacha20poly1305 BulkEncrypt key nonce =-    let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key)-     in ( \input ad ->-            let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st)-                (output, st3) = ChaChaPoly1305.encrypt input st2-                Poly1305.Auth tag = ChaChaPoly1305.finalize st3-             in (output, AuthTag tag)-        )-chacha20poly1305 BulkDecrypt key nonce =-    let st = noFail (ChaChaPoly1305.nonce12 nonce >>= ChaChaPoly1305.initialize key)-     in ( \input ad ->-            let st2 = ChaChaPoly1305.finalizeAAD (ChaChaPoly1305.appendAAD ad st)-                (output, st3) = ChaChaPoly1305.decrypt input st2-                Poly1305.Auth tag = ChaChaPoly1305.finalize st3-             in (output, AuthTag tag)-        )+chacha20poly1305 BulkEncrypt key =+    let ctx = noFail (ChaChaOne.newContext key)+     in \nonce d ad ->+            let sealed = noFail (ChaChaOne.encrypt ctx nonce ad d 16)+                (out, tag) = B.splitAt (B.length sealed - 16) sealed+             in (out, AuthTag (convert tag))+chacha20poly1305 BulkDecrypt key =+    let ctx = noFail (ChaChaOne.newContext key)+     in \nonce d ad -> noFail (ChaChaOne.decryptWithTag ctx nonce ad d 16)  ----------------------------------------------------------------
+ Network/TLS/Extra/CipherCBC.hs view
@@ -0,0 +1,201 @@+module Network.TLS.Extra.CipherCBC (+    -- * TLS 1.2 CBC ciphers with PFS and SHA2+    ciphersuite_pfs_sha2_cbc,+    ciphersuite_ecdhe_sha2_cbc,+    ciphersuite_dhe_rsa_sha2_cbc,++    -- ** Individual CBC ciphers+    cipher_DHE_RSA_AES128_SHA256,+    cipher_DHE_RSA_AES256_SHA256,+    cipher_ECDHE_RSA_AES128CBC_SHA256,+    cipher_ECDHE_RSA_AES256CBC_SHA384,+    cipher_ECDHE_ECDSA_AES128CBC_SHA256,+) where++import Crypto.Cipher.AES+import Crypto.Cipher.Types hiding (Cipher, cipherName)+import Crypto.Error+-- import Crypto.System.CPU+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types hiding (IV)++----------------------------------------------------------------++-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_pfs_sha2_cbc :: [Cipher]+ciphersuite_pfs_sha2_cbc =+    [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+    , cipher_ECDHE_ECDSA_AES256CBC_SHA384+    , cipher_ECDHE_RSA_AES128CBC_SHA256+    , cipher_ECDHE_RSA_AES256CBC_SHA384+    , cipher_DHE_RSA_AES128_SHA256+    , cipher_DHE_RSA_AES256_SHA256+    ]++-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_ecdhe_sha2_cbc :: [Cipher]+ciphersuite_ecdhe_sha2_cbc =+    [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+    , cipher_ECDHE_ECDSA_AES256CBC_SHA384+    , cipher_ECDHE_RSA_AES128CBC_SHA256+    , cipher_ECDHE_RSA_AES256CBC_SHA384+    ]++-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a+-- SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_dhe_rsa_sha2_cbc :: [Cipher]+ciphersuite_dhe_rsa_sha2_cbc =+    [ cipher_DHE_RSA_AES256_SHA256+    , cipher_DHE_RSA_AES128_SHA256+    ]++----------------------------------------------------------------++-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES128_SHA256 :: Cipher+cipher_DHE_RSA_AES128_SHA256 =+    Cipher+        { cipherID = 0x0067+        , cipherName = "DHE-RSA-AES128-SHA256"+        , cipherBulk = bulk_aes128+        , cipherHash = SHA256+        , cipherPRFHash = Just SHA256+        , cipherKeyExchange = CipherKeyExchange_DHE_RSA+        , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+        }++-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES256_SHA256 :: Cipher+cipher_DHE_RSA_AES256_SHA256 =+    cipher_DHE_RSA_AES128_SHA256+        { cipherID = 0x006B+        , cipherName = "DHE-RSA-AES256-SHA256"+        , cipherBulk = bulk_aes256+        }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128CBC_SHA256 =+    Cipher+        { cipherID = 0xC027+        , cipherName = "ECDHE-RSA-AES128CBC-SHA256"+        , cipherBulk = bulk_aes128+        , cipherHash = SHA256+        , cipherPRFHash = Just SHA256+        , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+        , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+        }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_RSA_AES256CBC_SHA384 =+    Cipher+        { cipherID = 0xC028+        , cipherName = "ECDHE-RSA-AES256CBC-SHA384"+        , cipherBulk = bulk_aes256+        , cipherHash = SHA384+        , cipherPRFHash = Just SHA384+        , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+        , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+        }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CBC_SHA256 =+    Cipher+        { cipherID = 0xc023+        , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256"+        , cipherBulk = bulk_aes128+        , cipherHash = SHA256+        , cipherPRFHash = Just SHA256+        , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+        , cipherMinVer = Just TLS12 -- RFC 5289+        }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_ECDSA_AES256CBC_SHA384 =+    Cipher+        { cipherID = 0xC024+        , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384"+        , cipherBulk = bulk_aes256+        , cipherHash = SHA384+        , cipherPRFHash = Just SHA384+        , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+        , cipherMinVer = Just TLS12 -- RFC 5289+        }++----------------------------------------------------------------++aes128cbc :: BulkDirection -> BulkKey -> BulkBlock+aes128cbc BulkEncrypt key =+    let ctx = noFail (cipherInit key) :: AES128+     in ( \iv input ->+            let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+        )+aes128cbc BulkDecrypt key =+    let ctx = noFail (cipherInit key) :: AES128+     in ( \iv input ->+            let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+        )++aes256cbc :: BulkDirection -> BulkKey -> BulkBlock+aes256cbc BulkEncrypt key =+    let ctx = noFail (cipherInit key) :: AES256+     in ( \iv input ->+            let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+        )+aes256cbc BulkDecrypt key =+    let ctx = noFail (cipherInit key) :: AES256+     in ( \iv input ->+            let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+        )++makeIV_ :: BlockCipher a => B.ByteString -> IV a+makeIV_ = fromMaybe (error "makeIV_") . makeIV++takelast :: Int -> B.ByteString -> B.ByteString+takelast i b = B.drop (B.length b - i) b++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++----------------------------------------------------------------++bulk_aes128 :: Bulk+bulk_aes128 =+    Bulk+        { bulkName = "AES128"+        , bulkKeySize = 16+        , bulkIVSize = 16+        , bulkExplicitIV = 0+        , bulkAuthTagLen = 0+        , bulkBlockSize = 16+        , bulkF = BulkBlockF aes128cbc+        }++bulk_aes256 :: Bulk+bulk_aes256 =+    Bulk+        { bulkName = "AES256"+        , bulkKeySize = 32+        , bulkIVSize = 16+        , bulkExplicitIV = 0+        , bulkAuthTagLen = 0+        , bulkBlockSize = 16+        , bulkF = BulkBlockF aes256cbc+        }
Network/TLS/Handshake.hs view
@@ -25,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken.  So contrary to 'handshake' above, here we only need to -- call withWriteLock.-handshakeWith :: MonadIO m => Context -> Handshake -> m ()-handshakeWith ctx hs =+handshakeWith :: MonadIO m => Context -> HandshakeR -> m ()+handshakeWith ctx hsr =     liftIO $         withWriteLock ctx $             handleException ctx $-                doHandshakeWith_ (ctxRoleParams ctx) ctx hs+                doHandshakeWith_ (ctxRoleParams ctx) ctx hsr
Network/TLS/Handshake/Certificate.hs view
@@ -3,13 +3,20 @@     badCertificate,     rejectOnException,     verifyLeafKeyUsage,+    verifyLeafKeyUsagePurpose,     extractCAname, ) where -import Control.Exception (SomeException)+import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet)+import Data.X509 (+    ExtExtendedKeyUsage (..),+    ExtKeyUsage (..),+    ExtKeyUsageFlag,+    ExtKeyUsagePurpose (..),+    extensionGet,+ )  import Network.TLS.Context.Internal import Network.TLS.Struct@@ -31,7 +38,7 @@ badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol msg BadCertificate -rejectOnException :: SomeException -> IO CertificateUsage+rejectOnException :: E.SomeException -> IO CertificateUsage rejectOnException e = return $ CertificateUsageReject $ CertificateRejectOther $ show e  verifyLeafKeyUsage :: MonadIO m => [ExtKeyUsageFlag] -> CertificateChain -> m ()@@ -46,6 +53,19 @@         case extensionGet (certExtensions cert) of             Nothing -> True -- unrestricted cert             Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags++verifyLeafKeyUsagePurpose+    :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m ()+verifyLeafKeyUsagePurpose _ (CertificateChain []) = return ()+verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) =+    unless verified $+        badCertificate $+            "certificate is not allowed for " ++ show validPurpose+  where+    cert = getCertificate signed+    verified = case extensionGet (certExtensions cert) of+        Nothing -> True+        Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes  extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert
Network/TLS/Handshake/Client.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module Network.TLS.Handshake.Client (     handshakeClient,@@ -26,8 +27,9 @@  ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()-handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx+handshakeClientWith+    :: ClientParams -> Context -> HandshakeR -> IO ()+handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ =     throwCore $         Error_Protocol@@ -38,16 +40,34 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do-    groups <- case clientSessions cparams of-        [] -> return groupsSupported+    grps <- case clientSessions cparams of+        [] ->+            return $+                Groups+                    { grpsSupported = groupsSupported+                    , grpsSelected = groupsSelected+                    }         (_, sdata) : _ -> case sessionGroup sdata of-            Nothing -> return [] -- TLS 1.2 or earlier+            Nothing ->+                -- TLS 1.2 or earlier+                return $+                    Groups+                        { grpsSupported = groupsSupported -- for ciphers+                        , grpsSelected = []+                        }             Just grp-                | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported+                | grp `elem` groupsSupported -> do+                    let supported = grp : filter (/= grp) groupsSupported+                    return $+                        Groups+                            { grpsSupported = supported+                            , grpsSelected = [grp]+                            }                 | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect"-    handshake cparams ctx groups Nothing+    handshake cparams ctx grps Nothing   where     groupsSupported = supportedGroups (ctxSupported ctx)+    groupsSelected = onSelectKeyShareGroups (clientHooks cparams) groupsSupported  -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a@@ -59,10 +79,10 @@ handshake     :: ClientParams     -> Context-    -> [Group]+    -> Groups     -> Maybe (ClientRandom, Session, Version)     -> IO ()-handshake cparams ctx groups mparams = do+handshake cparams ctx grps@Groups{..} mparams = do     --------------------------------     -- Sending ClientHello     pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx@@ -70,21 +90,21 @@     let async = rtt0 && not (ctxQUICMode ctx)     when async $ do         chSentTime <- getCurrentTimeFromBase-        asyncServerHello13 cparams ctx groupToSend chSentTime+        asyncServerHello13 cparams ctx grpsSelected chSentTime     updateMeasure ctx incrementNbHandshakes-    crand <- sendClientHello cparams ctx groups mparams pskinfo+    crand <-+        sendClientHello cparams ctx grps mparams pskinfo     --------------------------------     -- Receiving ServerHello     unless async $ do-        (ver, hss, hrr) <- receiveServerHello cparams ctx mparams-        --------------------------------+        (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams         -- Switching to HRR, TLS 1.2 or TLS 1.3         case ver of             TLS13                 | hrr ->-                    helloRetry cparams ctx mparams ver crand $ drop 1 groups+                    helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected                 | otherwise -> do-                    recvServerSecondFlight13 cparams ctx groupToSend+                    recvServerSecondFlight13 cparams ctx grpsSelected                     sendClientSecondFlight13 cparams ctx             _                 | rtt0 ->@@ -93,11 +113,9 @@                             "server denied TLS 1.3 when connecting with early data"                             HandshakeFailure                 | otherwise -> do-                    recvServerFirstFlight12 cparams ctx hss+                    recvServerFirstFlight12 cparams ctx hbs                     sendClientSecondFlight12 cparams ctx                     recvServerSecondFlight12 cparams ctx-  where-    groupToSend = listToMaybe groups  ---------------------------------------------------------------- @@ -108,24 +126,46 @@     -> Version     -> ClientRandom     -> [Group]+    -> [Group]     -> IO ()-helloRetry cparams ctx mparams ver crand groups = do-    when (null groups) $+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do+    when (null groupsSupported) $         throwCore $-            Error_Protocol "group is exhausted in the client side" IllegalParameter+            Error_Protocol "no supported groups on the client side" IllegalParameter     when (isJust mparams) $         throwCore $             Error_Protocol "server sent too many hello retries" UnexpectedMessage     mks <- usingState_ ctx getTLS13KeyShare     case mks of         Just (KeyShareHRR selectedGroup)-            | selectedGroup `elem` groups -> do+            -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups+            -- and MUST NOT already have been offered in the initial key_share.+            | selectedGroup `elem` groupsSupported+                && selectedGroup `notElem` groupsSelected -> do                 usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest                 clearTxRecordState ctx                 let cparams' = cparams{clientUseEarlyData = False}                 runPacketFlight ctx $ sendChangeCipherSpec13 ctx                 clientSession <- tls13stSession <$> getTLS13State ctx-                handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))+                -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical+                -- to the first except for the specific listed changes.+                -- supported_groups is NOT on that list, so it must be unchanged.+                let grps =+                        Groups+                            { grpsSupported = groupsSupported+                            , grpsSelected = [selectedGroup]+                            }++                handshake+                    cparams'+                    ctx+                    grps+                    (Just (crand, clientSession, ver))+            | selectedGroup `elem` groupsSelected ->+                throwCore $+                    Error_Protocol+                        "server selected a group already offered in key_share"+                        IllegalParameter             | otherwise ->                 throwCore $                     Error_Protocol "server-selected group is not supported" IllegalParameter
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -5,10 +5,13 @@ module Network.TLS.Handshake.Client.ClientHello (     sendClientHello,     getPreSharedKeyInfo,+    Groups (..), ) where  import qualified Control.Exception as E-import Crypto.HPKE+import Crypto.HPKE hiding (CipherText, PlainText)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.ECH.Config import System.Random@@ -41,16 +44,26 @@  ---------------------------------------------------------------- +data Groups = Groups+    { grpsSupported :: [Group]+    -- ^ For supported_group, head is identical to key_share+    , grpsSelected :: [Group]+    -- ^ For key_share+    }+    deriving (Eq, Show)++----------------------------------------------------------------+ sendClientHello     :: ClientParams     -> Context-    -> [Group]+    -> Groups     -> Maybe (ClientRandom, Session, Version)     -> PreSharedKeyInfo     -> IO ClientRandom-sendClientHello cparams ctx groups mparams pskinfo = do+sendClientHello cparams ctx grps mparams pskinfo = do     crand <- generateClientHelloParams mparams -- Inner for ECH-    sendClientHello' cparams ctx groups crand pskinfo+    sendClientHello' cparams ctx grps crand pskinfo     return crand   where     highestVer = maximum $ supportedVersions $ ctxSupported ctx@@ -89,14 +102,14 @@ sendClientHello'     :: ClientParams     -> Context-    -> [Group]+    -> Groups     -> ClientRandom     -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32)        , Maybe CipherChoice        , Bool        )     -> IO ()-sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do+sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do     let ver = if tls13 then TLS12 else highestVer     clientSession <- tls13stSession <$> getTLS13State ctx     hrr <- usingState_ ctx getTLS13HRR@@ -127,17 +140,22 @@                 Nothing -> do                     if hrr                         then do-                            chI <- fromJust <$> usingHState ctx getClientHello+                            (chI, _) <- fromJust <$> usingHState ctx getClientHello                             let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)}-                            usingHState ctx $ setClientHello ch0'+                            -- [] will be overridden via+                            -- encodeUpdateTranscriptHash12+                            usingHState ctx $ setClientHello ch0' []                             return ch0'                         else do                             gEchExt <- greasingEchExt                             let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)}-                            usingHState ctx $ setClientHello ch0'+                            -- [] will be overridden via+                            -- encodeUpdateTranscriptHash12+                            usingHState ctx $ setClientHello ch0' []                             return ch0'                 Just echParams -> do-                    usingHState ctx $ setClientHello ch0+                    let encoded = encodeHandshake $ ClientHello ch0+                    usingHState ctx $ setClientHello ch0 [encoded]                     mcrandO <- usingHState ctx getOuterClientRandom                     crandO <- case mcrandO of                         Nothing -> clientRandom ctx@@ -148,9 +166,11 @@                     mpskExt <- randomPreSharedKeyExt                     createEncryptedClientHello ctx ch0 echParams crandO mpskExt             else do-                usingHState ctx $ setClientHello ch0+                -- [] will be overridden via+                -- encodeUpdateTranscriptHash12+                usingHState ctx $ setClientHello ch0 []                 return ch0-    sendPacket12 ctx $ Handshake [ClientHello ch]+    sendPacket12 ctx $ Handshake [ClientHello ch] []     mEarlySecInfo <- case rtt0info of         Nothing -> return Nothing         Just info -> Just <$> getEarlySecretInfo info@@ -162,7 +182,6 @@     highestVer = maximum $ supportedVersions $ ctxSupported ctx     tls13 = highestVer >= TLS13     ems = supportedExtendedMainSecret $ ctxSupported ctx-    groupToSend = listToMaybe groups      -- List of extensions to send in ClientHello, ordered such that we never     -- terminate with a zero-length extension.  Some buggy implementations@@ -196,19 +215,21 @@      -------------------- +    -- RFC 6066 Section 3: HostName is <1..2^16-1>, so no server_name+    -- is sent for an empty name.     sniExt =-        if clientUseServerNameIndication cparams+        if clientUseServerNameIndication cparams && not (null sni)             then do-                let sni = fst $ clientServerIdentification cparams                 usingState_ ctx $ setClientSNI sni                 return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni]             else return Nothing+      where+        sni = fst $ clientServerIdentification cparams -    groupExt =-        return $-            Just $-                toExtensionRaw $-                    SupportedGroups (supportedGroups $ ctxSupported ctx)+    -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond+    -- to a group offered in the "supported_groups" extension and MUST+    -- appear in the same order.+    groupExt = return $ Just $ toExtensionRaw $ SupportedGroups grpsSupported      ecPointExt =         return $@@ -244,11 +265,13 @@         Nothing -> return Nothing         Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz -    sessionTicketExt = do+    sessionTicketExt =         case clientSessions cparams of             (sidOrTkt, _) : _                 | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt-            _ -> return $ Just $ toExtensionRaw $ SessionTicket ""+            _+                | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket ""+                | otherwise -> return $ Nothing      earlyDataExt         | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)@@ -282,14 +305,11 @@         | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth         | otherwise = return Nothing -    -- FIXME     keyShareExt-        | tls13 = case groupToSend of-            Nothing -> return Nothing-            Just grp -> do-                (cpri, ent) <- makeClientKeyShare ctx grp-                usingHState ctx $ setGroupPrivate cpri-                return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]+        | tls13 = do+            (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected+            usingHState ctx $ setGroupPrivate grpCpris+            return $ Just $ toExtensionRaw $ KeyShareClientHello ents         | otherwise = return Nothing      secureRenegExt =@@ -312,7 +332,7 @@                     pskIdentities = map (\x -> PskIdentity x obfAge) identities                     -- [zero] is a place holds.                     -- adjustPreSharedKeyExt will replace them.-                    binders = replicate (length pskIdentities) zero+                    binders = replicate (length pskIdentities) $ convert zero                     offeredPsks = PreSharedKeyClientHello pskIdentities binders                 return $ Just $ toExtensionRaw offeredPsks @@ -322,7 +342,7 @@             Nothing -> return Nothing             Just (identities, _, choice, _) -> do                 let zero = cZero choice-                zeroR <- getStdRandom $ uniformByteString $ B.length zero+                zeroR <- getStdRandom $ uniformByteString $ BA.length zero                 obfAgeR <- getStdRandom genWord32                 let genPskId x = do                         xR <- getStdRandom $ uniformByteString $ B.length x@@ -491,9 +511,13 @@     step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) =         (sniExtO : os, sniExtI : is)       where-        sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host]         (os, is) = step3 exts id-    step2 _ = error "step2"+    -- No server_name for an empty name: only the outer one names the+    -- public name.+    step2 exts = (sniExtO : os, is)+      where+        (os, is) = step3 exts id+    sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host]     step3 [] build = ([], [echOuterExt])       where         echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []
Network/TLS/Handshake/Client/Common.hs view
@@ -13,9 +13,10 @@     clientSessions, ) where -import Control.Exception (SomeException)+import qualified Control.Exception as E import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import qualified Data.ByteString as B+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..))  import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -38,7 +39,7 @@  ---------------------------------------------------------------- -throwMiscErrorOnException :: String -> SomeException -> IO a+throwMiscErrorOnException :: String -> E.SomeException -> IO a throwMiscErrorOnException msg e =     throwCore $ Error_Misc $ msg ++ ": " ++ show e @@ -124,7 +125,9 @@     -- then run certificate validation     usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException     case usage of-        CertificateUsageAccept -> checkLeafCertificateKeyUsage+        CertificateUsageAccept -> do+            verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs+            checkLeafCertificateKeyUsage         CertificateUsageReject reason -> certificateRejected reason   where     shared = clientShared cparams@@ -342,14 +345,28 @@         (return ())         setAlpn   where-    setAlpn (ApplicationLayerProtocolNegotiation [proto]) = usingState_ ctx $ do-        mprotos <- getClientALPNSuggest+    setAlpn (ApplicationLayerProtocolNegotiation [proto]) = do+        mprotos <- usingState_ ctx getClientALPNSuggest         case mprotos of-            Just protos -> when (proto `elem` protos) $ do-                setExtensionALPN True-                setNegotiatedProtocol proto-            _ -> return ()-    setAlpn _ = return ()+            Nothing ->+                throwCore $+                    Error_Protocol+                        "server sent ALPN without a client offer"+                        UnsupportedExtension+            Just protos+                | not (B.null proto) && proto `elem` protos -> usingState_ ctx $ do+                    setExtensionALPN True+                    setNegotiatedProtocol proto+                | otherwise ->+                    throwCore $+                        Error_Protocol+                            "server selected an ALPN protocol not offered by the client"+                            IllegalParameter+    setAlpn _ =+        throwCore $+            Error_Protocol+                "server ALPN response did not contain exactly one protocol"+                IllegalParameter  ----------------------------------------------------------------
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -6,6 +6,7 @@     processServerHello13, ) where +import Data.ByteArray (convert) import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -35,12 +36,12 @@     :: ClientParams     -> Context     -> Maybe (ClientRandom, Session, Version)-    -> IO (Version, [Handshake], Bool)+    -> IO (Version, [HandshakeR], Bool) receiveServerHello cparams ctx mparams = do     chSentTime <- getCurrentTimeFromBase-    (sh, hss) <- recvSH+    (shb@(sh, _), hbs) <- recvSH     processServerHello cparams ctx sh-    void $ updateTranscriptHash12 ctx sh+    updateTranscriptHash12 ctx shb     setRTT ctx chSentTime     ver <- usingState_ ctx getVersion     unless (maybe True (\(_, _, v) -> v == ver) mparams) $@@ -51,7 +52,7 @@     -- False otherwise.  For 2nd server hello, getTLS13HR returns     -- False since it is NOT HRR.     hrr <- usingState_ ctx getTLS13HRR-    return (ver, hss, hrr)+    return (ver, hbs, hrr)   where     recvSH = do         epkt <- recvPacket12 ctx@@ -59,7 +60,7 @@             Left e -> throwCore e             Right pkt -> case pkt of                 Alert a -> throwAlert a-                Handshake (h : hs) -> return (h, hs)+                Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs)                 _ -> unexpected (show pkt) (Just "handshake")     throwAlert a =         throwCore $@@ -137,6 +138,12 @@      ver <- usingState_ ctx getVersion +    unless (cipherAllowedForVersion ver usedCipher) $+        throwCore $+            Error_Protocol+                "server selected a cipher invalid for the negotiated version"+                IllegalParameter+     when (ver == TLS12) $         setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg @@ -179,7 +186,7 @@             transitTranscriptHashI ctx "transitI" usedHash isHRR             accepted <- checkECHacceptance ctx isHRR usedHash sh             when accepted $ do-                CH{..} <- fromJust <$> usingHState ctx getClientHello+                (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello                 usingHState ctx $ setClientRandom chRandom -- inner random             when (accepted && not isHRR) $ do                 copyTranscriptHash ctx "copy"@@ -245,7 +252,7 @@             when (ems /= emsSession) $                 let err = "server resumes a session which is not EMS consistent"                  in throwCore $ Error_Protocol err HandshakeFailure-            let mainSecret = sessionSecret sessionData+            let mainSecret = convert $ sessionSecret sessionData             usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret             logKey ctx (MainSecret mainSecret)
Network/TLS/Handshake/Client/TLS12.hs view
@@ -8,6 +8,7 @@ ) where  import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -32,14 +33,15 @@  ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()-recvServerFirstFlight12 cparams ctx hs = do+recvServerFirstFlight12+    :: ClientParams -> Context -> [HandshakeR] -> IO ()+recvServerFirstFlight12 cparams ctx hbs = do     resuming <- usingState_ ctx getTLS12SessionResuming     if resuming         then recvNSTandCCSandFinished ctx         else do             let st = RecvStateHandshake (expectCertificate cparams ctx)-            runRecvStateHS ctx st hs+            runRecvStateHS ctx st hbs  expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do@@ -151,7 +153,7 @@             unless (null certs) $                 usingHState ctx $                     setClientCertSent True-            sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)]+            sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] []  ---------------------------------------------------------------- @@ -167,19 +169,19 @@         _ ->             throwCore $                 Error_Protocol "client key exchange unsupported type" HandshakeFailure-    sendPacket12 ctx $ Handshake [ClientKeyXchg ckx]+    sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] []     mainSecret <- usingHState ctx setMainSec     logKey ctx (MainSecret mainSecret)  --------------------------------  getCKX_RSA-    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_RSA ctx = do     clientVersion <- usingHState ctx $ gets hstClientVersion     (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 -    let preMain = encodePreMainSecret clientVersion prerand+    let preMain = convert $ encodePreMainSecret clientVersion prerand         setMainSec = setMainSecretFromPre xver ClientRole preMain     encryptedPreMain <- do         -- SSL3 implementation generally forget this length field since it's redundant,@@ -194,7 +196,7 @@ getCKX_DHE     :: ClientParams     -> Context-    -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+    -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_DHE cparams ctx = do     xver <- usingState_ ctx getVersion     serverParams <- usingHState ctx getServerDHParams@@ -241,12 +243,12 @@ --------------------------------  getCKX_ECDHE-    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_ECDHE ctx = do     ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams     checkSupportedGroup ctx grp     usingHState ctx $ setSupportedGroup grp-    ecdhePair <- generateECDHEShared ctx srvpub+    ecdhePair <- encapsulateGroup ctx srvpub     case ecdhePair of         Nothing ->             throwCore $@@ -254,7 +256,7 @@         Just (clipub, preMain) -> do             xver <- usingState_ ctx getVersion             let setMainSec = setMainSecretFromPre xver ClientRole preMain-            return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec)+            return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec)  ---------------------------------------------------------------- @@ -283,4 +285,4 @@         -- Fetch all handshake messages up to now.         msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages         sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs-        sendPacket12 ctx $ Handshake [CertVerify sigDig]+        sendPacket12 ctx $ Handshake [CertVerify sigDig] []
Network/TLS/Handshake/Client/TLS13.hs view
@@ -7,9 +7,9 @@     postHandshakeAuthClientWith, ) where -import Control.Exception (bracket)+import qualified Control.Exception as E import Control.Monad.State.Strict-import qualified Data.ByteString as B+import qualified Data.ByteArray as BA import Data.IORef  import Network.TLS.Cipher@@ -39,7 +39,7 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -recvServerSecondFlight13 :: ClientParams -> Context -> Maybe Group -> IO ()+recvServerSecondFlight13 :: ClientParams -> Context -> [Group] -> IO () recvServerSecondFlight13 cparams ctx groupSent = do     resuming <- prepareSecondFlight13 ctx groupSent     runRecvHandshake13 $ do@@ -50,14 +50,14 @@ ----------------------------------------------------------------  prepareSecondFlight13-    :: Context -> Maybe Group -> IO Bool+    :: Context -> [Group] -> IO Bool prepareSecondFlight13 ctx groupSent = do     choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher     prepareSecondFlight13' ctx groupSent choice  prepareSecondFlight13'     :: Context-    -> Maybe Group+    -> [Group]     -> CipherChoice     -> IO Bool prepareSecondFlight13' ctx groupSent choice = do@@ -100,10 +100,10 @@                             "key exchange not implemented, expected key_share extension"                             HandshakeFailure         let grp = keyShareEntryGroup serverKeyShare-        unless (checkKeyShareKeyLength serverKeyShare) $+        unless (checkServerKeyShareKeyLength serverKeyShare) $             throwCore $                 Error_Protocol "broken key_share" IllegalParameter-        unless (groupSent == Just grp) $+        unless (grp `elem` groupSent) $             throwCore $                 Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter         usingHState ctx $ setSupportedGroup grp@@ -119,7 +119,7 @@                     Nothing ->                         return (initEarlySecret choice Nothing, False)                     Just (PreSharedKeyServerHello 0) -> do-                        unless (B.length sec == hashSize) $+                        unless (BA.length sec == hashSize) $                             throwCore $                                 Error_Protocol                                     "selected cipher is incompatible with selected PSK"@@ -147,12 +147,13 @@             Nothing -> do                 usingHState ctx $ setTLS13HandshakeMode PreSharedKey                 usingHState ctx $ setTLS13RTT0Status RTT0Rejected-expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions")+expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions")  ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest-    :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+    :: MonadIO m+    => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do     processCertRequest13 ctx token exts     recvHandshake13 ctx $ expectCertAndVerify cparams ctx@@ -211,10 +212,11 @@ ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify-    :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m ()+    :: MonadIO m+    => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc-expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate")+expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate")  processCertAndVerify     :: MonadIO m@@ -231,11 +233,12 @@ ----------------------------------------------------------------  expectCertVerify-    :: MonadIO m => Context -> PubKey -> TranscriptHash -> Handshake13 -> m ()+    :: MonadIO m+    => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do     ok <- checkCertVerify ctx pubkey sigAlg sig hChSc     unless ok $ decryptError "cannot verify CertificateVerify"-expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify")+expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify")  ---------------------------------------------------------------- @@ -290,7 +293,7 @@         runPacketFlight ctx $             sendChangeCipherSpec13 ctx     when (rtt0accepted && not (ctxQUICMode ctx)) $-        sendPacket13 ctx (Handshake13 [EndOfEarlyData13])+        sendPacket13 ctx (Handshake13 [EndOfEarlyData13] [])     let clientHandshakeSecret = triClient hkey     setTxRecordState ctx usedHash usedCipher clientHandshakeSecret     sendClientFlight13 cparams ctx usedHash clientHandshakeSecret@@ -344,7 +347,7 @@                 certComp <- usingHState ctx getTLS13CertComp                 loadClientData13 cc reqtoken certComp         rawFinished <- makeFinished ctx usedHash baseKey-        loadPacket13 ctx $ Handshake13 [rawFinished]+        loadPacket13 ctx $ Handshake13 [rawFinished] []     when (isJust mcc) $         modifyTLS13State ctx $             \st -> st{tls13stSentClientCert = True}@@ -355,7 +358,7 @@             cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx         let certtag = if certComp then CompressedCertificate13 else Certificate13         loadPacket13 ctx $-            Handshake13 [certtag token (CertificateChain_ chain) certExts]+            Handshake13 [certtag token (CertificateChain_ chain) certExts] []         case certs of             [] -> return ()             _ -> do@@ -364,7 +367,7 @@                 sigAlg <-                     liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey                 vfy <- makeCertVerify ctx pubKey sigAlg hChSc-                loadPacket13 ctx $ Handshake13 [vfy]+                loadPacket13 ctx $ Handshake13 [vfy] []     --     loadClientData13 _ _ _ =         throwCore $@@ -373,10 +376,14 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =-    bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do-        void $ updateTranscriptHash13 ctx h+postHandshakeAuthClientWith+    :: ClientParams -> Context -> Handshake13R -> IO ()+postHandshakeAuthClientWith cparams ctx hb@(CertRequest13 certReqCtx exts, _) =+    E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+        -- RFC 8446 Section 4.4: the handshake context of+        -- post-handshake authentication is ClientHello ... client+        -- Finished + CertificateRequest.+        updateTranscriptHash13 ctx hb         processCertRequest13 ctx certReqCtx exts         (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx         unless (level == CryptApplicationSecret) $@@ -399,19 +406,19 @@ ----------------------------------------------------------------  asyncServerHello13-    :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO ()+    :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do     setPendingRecvActions         ctx-        [ PendingRecvAction True False expectServerHello-        , PendingRecvAction True True (expectEncryptedExtensions ctx)+        [ PendingRecvActionSelfUpdate True expectServerHello+        , PendingRecvAction True (expectEncryptedExtensions ctx)         , PendingRecvActionHash True expectFinishedAndSet         ]   where-    expectServerHello sh = do+    expectServerHello shb@(sh, _) = do         setRTT ctx chSentTime         processServerHello13 cparams ctx sh-        void $ updateTranscriptHash13 ctx sh -- update by myself+        updateTranscriptHash13 ctx shb -- update by myself         void $ prepareSecondFlight13 ctx groupSent     expectFinishedAndSet h sf = do         expectFinished cparams ctx h sf
Network/TLS/Handshake/Common.hs view
@@ -31,6 +31,7 @@     --     setPeerRecordSizeLimit,     generateFinished,+    encodeUpdateTranscriptHash12,     updateTranscriptHash12,     --     startHandshake,@@ -39,8 +40,9 @@ ) where  import Control.Concurrent.MVar-import Control.Exception (IOException, fromException, handle, throwIO)+import qualified Control.Exception as E import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -67,7 +69,7 @@ import Network.TLS.X509  handshakeFailed :: TLSError -> IO ()-handshakeFailed err = throwIO $ HandshakeFailed err+handshakeFailed err = E.throwIO $ HandshakeFailed err  handleException :: Context -> IO () -> IO () handleException ctx f = catchException f $ \exception -> do@@ -75,12 +77,12 @@     -- If the error was an Uncontextualized TLSException, we replace the     -- context with HandshakeFailed. If it's anything else, we convert     -- it to a string and wrap it with Error_Misc and HandshakeFailed.-    let tlserror = case fromException exception of+    let tlserror = case E.fromException exception of             Just e | Uncontextualized e' <- e -> e'             _ -> Error_Misc (show exception)     established <- ctxEstablished ctx     setEstablished ctx NotEstablished-    handle ignoreIOErr $ do+    E.handle ignoreIOErr $ do         tls13 <- tls13orLater ctx         if tls13             then do@@ -91,7 +93,7 @@             else sendPacket12 ctx $ Alert [errorToAlert tlserror]     handshakeFailed tlserror   where-    ignoreIOErr :: IOException -> IO ()+    ignoreIOErr :: E.IOException -> IO ()     ignoreIOErr _ = return ()  errorToAlert :: TLSError -> (AlertLevel, AlertDescription)@@ -101,6 +103,9 @@ errorToAlert (Error_Packet_Parsing msg)     | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion)     | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter)+    | "cannot be decompressed" `isInfixOf` msg = (AlertLevel_Fatal, BadCertificate)+    | "unsupported certificate compression algorithm" `isInfixOf` msg =+        (AlertLevel_Fatal, IllegalParameter)     | otherwise = (AlertLevel_Fatal, DecodeError) errorToAlert _ = (AlertLevel_Fatal, InternalError) @@ -132,7 +137,7 @@     enablePeerRecordLimit ctx     ver <- usingState_ ctx getVersion     verifyData <- VerifyData <$> generateFinished ctx ver role-    sendPacket12 ctx (Handshake [Finished verifyData])+    sendPacket12 ctx (Handshake [Finished verifyData] [])     usingState_ ctx $ setVerifyDataForSend verifyData     contextFlush ctx @@ -141,11 +146,11 @@     | RecvStateHandshake (Handshake -> m (RecvState m))     | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake]+recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do     pkts <- recvPacket12 ctx     case pkts of-        Right (Handshake l) -> return l+        Right (Handshake hss bss) -> return $ zip hss bss         Right x@(AppData _) -> do             -- If a TLS13 server decides to reject RTT0 data, the server should             -- skip records for RTT0 data up to the maximum limit.@@ -161,16 +166,18 @@  -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake-    :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)+    :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState-onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms)-onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do-    let finished = isFinished x-    unless finished $ void $ updateTranscriptHash12 ctx x-    nstate <- f x-    when finished $ void $ updateTranscriptHash12 ctx x-    onRecvStateHandshake ctx nstate xs-onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing+onRecvStateHandshake _ (RecvStatePacket f) hbs = do+    let (hss, bss) = unzip hbs+    f (Handshake hss bss)+onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do+    let finished = isFinished h+    unless finished $ void $ updateTranscriptHash12 ctx hb+    nstate <- f h+    when finished $ void $ updateTranscriptHash12 ctx hb+    onRecvStateHandshake ctx nstate hbs+onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing  isFinished :: Handshake -> Bool isFinished Finished{} = True@@ -184,8 +191,9 @@         >>= onRecvStateHandshake ctx iniState         >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO ()-runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx+runRecvStateHS+    :: Context -> RecvState IO -> [HandshakeR] -> IO ()+runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx  ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do@@ -239,7 +247,7 @@                         , sessionCipher = cipher                         , sessionCompression = compression                         , sessionClientSNI = sni-                        , sessionSecret = ms+                        , sessionSecret = convert ms                         , sessionGroup = Nothing                         , sessionTicketInfo = Nothing                         , sessionALPN = alpn@@ -359,15 +367,15 @@                 generateServerFinished ver cipher mainSecret thash  generateFinished'-    :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString-generateFinished' prf label mainSecret (TranscriptHash thash) = prf mainSecret seed 12+    :: PRF -> ByteString -> Secret -> TranscriptHash -> ByteString+generateFinished' prf label mainSecret (TranscriptHash thash) = convert $ prf mainSecret seed 12   where     seed = label <> thash  generateClientFinished     :: Version     -> Cipher-    -> ByteString+    -> Secret     -> TranscriptHash     -> ByteString generateClientFinished ver ciph =@@ -376,7 +384,7 @@ generateServerFinished     :: Version     -> Cipher-    -> ByteString+    -> Secret     -> TranscriptHash     -> ByteString generateServerFinished ver ciph =
Network/TLS/Handshake/Common13.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -36,7 +37,8 @@     calculateApplicationSecret,     calculateResumptionSecret,     derivePSK,-    checkKeyShareKeyLength,+    checkClientKeyShareKeyLength,+    checkServerKeyShareKeyLength,     setRTT,     computeConfirm,     updateTranscriptHash13,@@ -46,7 +48,7 @@  import Control.Concurrent.MVar import Control.Monad.State.Strict-import qualified Data.ByteArray as BA+import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..))@@ -68,7 +70,6 @@ import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC-import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State@@ -79,7 +80,7 @@  ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do     verifyData <-         VerifyData . makeVerifyData usedHash baseKey@@ -89,7 +90,7 @@  checkFinished     :: MonadIO m-    => Context -> Hash -> ByteString -> TranscriptHash -> VerifyData -> m ()+    => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m () checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do     let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue     when (B.length verifyData /= B.length verifyData') $@@ -98,7 +99,7 @@     unless (verifyData' == verifyData) $ decryptError "finished verification failed"     liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> TranscriptHash -> ByteString+makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString makeVerifyData usedHash baseKey (TranscriptHash th) =     hmac usedHash finishedKey th   where@@ -107,38 +108,41 @@  ---------------------------------------------------------------- -makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)+makeClientKeyShare+    :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry)+makeClientKeyShare ctx grp = do+    (cpri, cpub) <- generateGroup ctx grp+    let wcpub = IES.groupEncodePublicA cpub+        clientKeyShare = KeyShareEntry grp wcpub+    return ((grp, cpri), clientKeyShare)++makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of     Left e -> throwCore $ Error_Protocol (show e) IllegalParameter     Right cpub -> do-        ecdhePair <- generateECDHEShared ctx cpub+        ecdhePair <- encapsulateGroup ctx cpub         case ecdhePair of             Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter             Just (spub, share) ->-                let wspub = IES.encodeGroupPublic spub+                let wspub = IES.groupEncodePublicB spub                     serverKeyShare = KeyShareEntry grp wspub-                 in return (BA.convert share, serverKeyShare)+                 in return (share, serverKeyShare)   where-    ecpub = IES.decodeGroupPublic grp wcpub+    ecpub = IES.groupDecodePublicA grp wcpub     msgInvalidPublic = "invalid client " ++ show grp ++ " public key" -makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)-makeClientKeyShare ctx grp = do-    (cpri, cpub) <- generateECDHE ctx grp-    let wcpub = IES.encodeGroupPublic cpub-        clientKeyShare = KeyShareEntry grp wcpub-    return (cpri, clientKeyShare)--fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString-fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of+fromServerKeyShare+    :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret+fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of     Left e -> throwCore $ Error_Protocol (show e) IllegalParameter-    Right spub -> case IES.groupGetShared spub cpri of-        Just shared -> return $ BA.convert shared-        Nothing ->-            throwCore $-                Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+    Right spub -> case lookup grp grpCpris of+        Nothing -> throwCore err+        Just cpri -> case IES.groupDecapsulate spub cpri of+            Just shared -> return shared+            Nothing -> throwCore err   where-    espub = IES.decodeGroupPublic grp wspub+    err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+    espub = IES.groupDecodePublicB grp wspub  ---------------------------------------------------------------- @@ -171,18 +175,25 @@     -> Signature     -> ByteString     -> m Bool-checkCertVerify ctx pub hs signature hashValue-    | pub `signatureCompatible13` hs = liftIO $ do-        role <- usingState_ ctx getRole-        let ctxStr-                | role == ClientRole = serverContextString -- opposite context-                | otherwise = clientContextString-            target = makeTarget ctxStr hashValue-            sigParams = signatureParams pub hs-        checkHashSignatureValid13 hs-        checkSupportedHashSignature ctx hs-        verifyPublic ctx sigParams target signature-    | otherwise = return False+-- RFC 8446 Section 6.2: an algorithm that may not be used -- one TLS 1.3+-- does not allow, one not offered, or one that does not fit the key -- is a+-- field that is incorrect, an illegal_parameter.  Only a signature that does+-- not verify is a decrypt_error, which False leads to.+checkCertVerify ctx pub hs signature hashValue = liftIO $ do+    checkHashSignatureValid13 hs+    checkSupportedHashSignature ctx hs+    unless (pub `signatureCompatible13` hs) $+        throwCore $+            Error_Protocol+                ("signature algorithm " ++ show hs ++ " does not fit the public key")+                IllegalParameter+    role <- usingState_ ctx getRole+    let ctxStr+            | role == ClientRole = serverContextString -- opposite context+            | otherwise = clientContextString+        target = makeTarget ctxStr hashValue+        sigParams = signatureParams pub hs+    verifyPublic ctx sigParams target signature  makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do@@ -373,7 +384,8 @@  ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a)+newtype RecvHandshake13M m a+    = RecvHandshake13M (StateT [Handshake13R] m a)     deriving (Functor, Applicative, Monad, MonadIO)  recvHandshake13@@ -381,7 +393,7 @@     => Context     -> (Handshake13 -> RecvHandshake13M m a)     -> RecvHandshake13M m a-recvHandshake13 ctx f = getHandshake13 ctx >>= f+recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h  recvHandshake13hash     :: MonadIO m@@ -391,21 +403,22 @@     -> RecvHandshake13M m a recvHandshake13hash ctx label f = do     d <- transcriptHash ctx label-    getHandshake13 ctx >>= f d+    getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13+getHandshake13+    :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do     currentState <- get     case currentState of-        (h : hs) -> found h hs-        [] -> recvLoop+        hb : hbs -> found hb hbs+        _ -> recvLoop   where-    found h hs = liftIO (void $ updateTranscriptHash13 ctx h) >> put hs >> return h+    found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb     recvLoop = do         epkt <- liftIO (recvPacket13 ctx)         case epkt of-            Right (Handshake13 []) -> error "invalid recvPacket13 result"-            Right (Handshake13 (h : hs)) -> found h hs+            Right (Handshake13 [] _) -> error "invalid recvPacket13 result"+            Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs             Right ChangeCipherSpec13 -> do                 alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv                 if alreadyReceived@@ -462,11 +475,11 @@     -> Either ByteString (BaseSecret EarlySecret)     -> IO (SecretPair EarlySecret) calculateEarlySecret ctx choice maux = do-    ch <- fromJust <$> usingHState ctx getClientHello-    let hCh = TranscriptHash $ hash usedHash $ encodeHandshake $ ClientHello ch+    (_ch, b) <- fromJust <$> usingHState ctx getClientHello+    let hCh = TranscriptHash $ hashChunks usedHash b     let earlySecret = case maux of             Right (BaseSecret sec) -> sec-            Left psk -> hkdfExtract usedHash zero psk+            Left psk -> hkdfExtract usedHash zero (convert psk)         clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh         cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret     logKey ctx cets@@ -481,13 +494,13 @@     sec = hkdfExtract usedHash zero zeroOrPSK     usedHash = cHash choice     zero = cZero choice-    zeroOrPSK = fromMaybe zero mpsk+    zeroOrPSK = fromMaybe zero (convert <$> mpsk)  calculateHandshakeSecret     :: Context     -> CipherChoice     -> BaseSecret EarlySecret-    -> ByteString+    -> Secret     -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do     hChSh <- transcriptHash ctx "CH..SH"@@ -561,25 +574,60 @@  ---------------------------------------------------------------- -checkKeyShareKeyLength :: KeyShareEntry -> Bool-checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key+checkClientKeyShareKeyLength :: KeyShareEntry -> Bool+checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key   where     grp = keyShareEntryGroup ks     key = keyShareEntryKeyExchange ks -keyShareKeyLength :: Group -> Int-keyShareKeyLength P256 = 65 -- 32 * 2 + 1-keyShareKeyLength P384 = 97 -- 48 * 2 + 1-keyShareKeyLength P521 = 133 -- 66 * 2 + 1-keyShareKeyLength X25519 = 32-keyShareKeyLength X448 = 56-keyShareKeyLength FFDHE2048 = 256-keyShareKeyLength FFDHE3072 = 384-keyShareKeyLength FFDHE4096 = 512-keyShareKeyLength FFDHE6144 = 768-keyShareKeyLength FFDHE8192 = 1024-keyShareKeyLength _ = error "keyShareKeyLength"+{- FOURMOLU_DISABLE -}+clientKeyShareKeyLength :: Group -> Int+clientKeyShareKeyLength P256   = 65  -- 32 * 2 + 1+clientKeyShareKeyLength P384   = 97  -- 48 * 2 + 1+clientKeyShareKeyLength P521   = 133 -- 66 * 2 + 1+clientKeyShareKeyLength X25519 = 32+clientKeyShareKeyLength X448   = 56+clientKeyShareKeyLength FFDHE2048 = 256+clientKeyShareKeyLength FFDHE3072 = 384+clientKeyShareKeyLength FFDHE4096 = 512+clientKeyShareKeyLength FFDHE6144 = 768+clientKeyShareKeyLength FFDHE8192 = 1024+clientKeyShareKeyLength MLKEM512  = 800+clientKeyShareKeyLength MLKEM768  = 1184+clientKeyShareKeyLength MLKEM1024 = 1568+clientKeyShareKeyLength X25519MLKEM768 = 1216+clientKeyShareKeyLength P256MLKEM768   = 1249+clientKeyShareKeyLength P384MLKEM1024  = 1665+clientKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -} +checkServerKeyShareKeyLength :: KeyShareEntry -> Bool+checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key+  where+    grp = keyShareEntryGroup ks+    key = keyShareEntryKeyExchange ks++{- FOURMOLU_DISABLE -}+serverKeyShareKeyLength :: Group -> Int+serverKeyShareKeyLength P256   = 65  -- 32 * 2 + 1+serverKeyShareKeyLength P384   = 97  -- 48 * 2 + 1+serverKeyShareKeyLength P521   = 133 -- 66 * 2 + 1+serverKeyShareKeyLength X25519 = 32+serverKeyShareKeyLength X448   = 56+serverKeyShareKeyLength FFDHE2048 = 256+serverKeyShareKeyLength FFDHE3072 = 384+serverKeyShareKeyLength FFDHE4096 = 512+serverKeyShareKeyLength FFDHE6144 = 768+serverKeyShareKeyLength FFDHE8192 = 1024+serverKeyShareKeyLength MLKEM512  = 768+serverKeyShareKeyLength MLKEM768  = 1088+serverKeyShareKeyLength MLKEM1024 = 1568+serverKeyShareKeyLength X25519MLKEM768 = 1120+serverKeyShareKeyLength P256MLKEM768   = 1153+serverKeyShareKeyLength P384MLKEM1024  = 1665+serverKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -}+ setRTT :: Context -> Millisecond -> IO () setRTT ctx chSentTime = do     shRecvTime <- getCurrentTimeFromBase@@ -591,11 +639,11 @@     :: (MonadFail m, MonadIO m)     => Context -> Hash -> ServerHello -> ByteString -> m ByteString computeConfirm ctx usedHash sh label = do-    CH{..} <- fromJust <$> liftIO (usingHState ctx getClientHello)+    (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello)     TranscriptHash echConf <-         transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh     let prk = hkdfExtract usedHash "" $ unClientRandom chRandom-    return $ hkdfExpandLabel usedHash prk label echConf 8+    return $ hkdfExpandLabel usedHash (convert prk) label echConf 8  ----------------------------------------------------------------
Network/TLS/Handshake/Control.hs view
@@ -7,6 +7,7 @@     NegotiatedProtocol, ) where +import Crypto.Debug (DebugShow (..)) import Network.TLS.Cipher import Network.TLS.Imports import Network.TLS.Struct@@ -19,17 +20,40 @@ type NegotiatedProtocol = ByteString  -- | Handshake information generated for traffic at 0-RTT level.+--+-- 'Show' renders the cipher and @\<secret\>@ for the key material; a trace+-- of what 'Network.TLS.QUIC.quicInstallKeys' is handed does not write the+-- traffic secrets to a log.  'Crypto.Debug.debugShow' renders them. data EarlySecretInfo = EarlySecretInfo Cipher (ClientTrafficSecret EarlySecret)     deriving (Show) +instance DebugShow EarlySecretInfo where+    debugShow (EarlySecretInfo c s) =+        "EarlySecretInfo " ++ show c ++ " " ++ debugShow s+ -- | Handshake information generated for traffic at handshake level.+--+-- The secrets are not shown; see 'EarlySecretInfo'. data HandshakeSecretInfo     = HandshakeSecretInfo Cipher (TrafficSecrets HandshakeSecret)     deriving (Show) +instance DebugShow HandshakeSecretInfo where+    debugShow (HandshakeSecretInfo c ts) =+        "HandshakeSecretInfo " ++ show c ++ " " ++ debugShowPair ts+ -- | Handshake information generated for traffic at application level.+--+-- The secrets are not shown; see 'EarlySecretInfo'. newtype ApplicationSecretInfo = ApplicationSecretInfo (TrafficSecrets ApplicationSecret)     deriving (Show)++instance DebugShow ApplicationSecretInfo where+    debugShow (ApplicationSecretInfo ts) =+        "ApplicationSecretInfo " ++ debugShowPair ts++debugShowPair :: TrafficSecrets a -> String+debugShowPair (c, s) = "(" ++ debugShow c ++ "," ++ debugShow s ++ ")"  ----------------------------------------------------------------
Network/TLS/Handshake/Key.hs view
@@ -7,8 +7,8 @@     decryptRSA,     verifyPublic,     generateDHE,-    generateECDHE,-    generateECDHEShared,+    generateGroup,+    encapsulateGroup,     generateFFDHE,     generateFFDHEShared,     versionCompatible,@@ -20,6 +20,7 @@ ) where  import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B  import Network.TLS.Context.Internal@@ -35,7 +36,7 @@ {- if the RSA encryption fails we just return an empty bytestring, and let the protocol  - fail by itself; however it would be probably better to just report it since it's an internal problem.  -}-encryptRSA :: Context -> ByteString -> IO ByteString+encryptRSA :: Context -> Secret -> IO ByteString encryptRSA ctx content = do     publicKey <- usingHState ctx getRemotePublicKey     usingState_ ctx $ do@@ -53,7 +54,7 @@             Left err -> error ("sign failed: " ++ show err)             Right econtent -> return econtent -decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString)+decryptRSA :: Context -> ByteString -> IO (Either KxError Secret) decryptRSA ctx econtent = do     (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys     usingState_ ctx $ do@@ -69,12 +70,12 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic)-generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp+generateGroup :: Context -> Group -> IO (GroupPrivate, GroupPublicA)+generateGroup ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared-    :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))-generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub+encapsulateGroup+    :: Context -> GroupPublicA -> IO (Maybe (GroupPublicB, GroupKey))+encapsulateGroup ctx pub = usingState_ ctx $ withRNG $ groupEncapsulate pub  generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp@@ -144,7 +145,7 @@ ----------------------------------------------------------------  class LogLabel a where-    labelAndKey :: a -> (String, ByteString)+    labelAndKey :: a -> (String, Secret)  instance LogLabel MainSecret where     labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key)@@ -175,6 +176,7 @@             let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst)                 cr = unClientRandom crm                 (label, key) = labelAndKey logkey-            debugKeyLogger (ctxDebug ctx) $ label ++ " " ++ dump cr ++ " " ++ dump key+            debugKeyLogger (ctxDebug ctx) $+                label ++ " " ++ dump cr ++ " " ++ dump (convert key)   where     dump = init . drop 1 . showBytesHex
Network/TLS/Handshake/Server.hs view
@@ -14,6 +14,7 @@  import Network.TLS.Context.Internal import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.ClientHello import Network.TLS.Handshake.Server.ClientHello12 import Network.TLS.Handshake.Server.ClientHello13@@ -21,6 +22,7 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13+import Network.TLS.Imports import Network.TLS.Struct  -- Put the server context in handshake mode.@@ -31,44 +33,57 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do-    hss <- recvPacketHandshake ctx-    case hss of-        [ch] -> handshake sparams ctx ch-        _ -> unexpected (show hss) (Just "client hello")+    hbs <- recvPacketHandshake ctx+    case hbs of+        chb : _ -> handshake sparams ctx chb+        _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()+handshakeServerWith+    :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake  -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter.--- This is useful when the client hello has been already poped from the recv layer to inspect the packet.+-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. ----- When the function returns, a new handshake has been succesfully negociated.+-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised.-handshake :: ServerParams -> Context -> Handshake -> IO ()-handshake sparams ctx (ClientHello ch) = do-    (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch+handshake :: ServerParams -> Context -> HandshakeR -> IO ()+handshake sparams ctx chb@(ClientHello ch, bs) = do+    (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs     if chosenVersion == TLS13         then do             -- fixme: we should check if the client random is the same as             -- that in the first client hello in the case of hello retry.-            (mClientKeyShare, r0, r1) <-+            -- r0 :: Cipher, Hash, Bool+            (keyShareResult, r0, r1) <-                 processClientHello13 sparams ctx chI-            case mClientKeyShare of-                Nothing -> do-                    sendHRR ctx r0 chI $ isJust mcrnd+            case keyShareResult of+                SelectKeyShareNotFound ->+                    throwCore $+                        Error_Protocol "no group in common with the client for HRR" HandshakeFailure+                SelectKeyShareHRR g -> do+                    sendHRR ctx g r0 chI $ isJust mcrnd                     -- Don't reset ctxEstablished since 0-RTT data-                    -- would be comming, which should be ignored.+                    -- would be coming, which should be ignored.                     handshakeServer sparams ctx-                Just cliKeyShare -> do+                SelectKeyShareFound cliKeyShare -> do+                    unless (checkClientKeyShareKeyLength cliKeyShare) $+                        throwCore $+                            Error_Protocol "broken key_share" IllegalParameter+                    -- r2 :: ( SecretTriple ApplicationSecret+                    --       , ClientTrafficSecret HandshakeSecret+                    --       , Bool  -- authenticated+                    --       , Bool) -- rtt0OK                     r2 <-                         sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd                     recvClientSecondFlight13 sparams ctx r2 chI         else do             r <-                 processClientHello12 sparams ctx chI+            updateTranscriptHash12 ctx chb             resumeSessionData <-                 sendServerHello12 sparams ctx r chI             recvClientSecondFlight12 sparams ctx resumeSessionData-handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure+handshake _ _ (hs, _) = unexpected (show hs) (Just "client hello")
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -29,12 +29,13 @@     :: ServerParams     -> Context     -> ClientHello+    -> [ByteString]     -> IO         ( Version         , ClientHello         , Maybe ClientRandom -- Just for ECH to keep the outer one for key log         )-processClientHello sparams ctx ch@CH{..} = do+processClientHello sparams ctx ch@CH{..} b = do     established <- ctxEstablished ctx     -- renego is not allowed in TLS 1.3     when (established /= NotEstablished) $ do@@ -56,7 +57,11 @@         (throwCore $ Error_HandshakePolicy "server: handshake denied")     updateMeasure ctx incrementNbHandshakes -    when (chVersion /= TLS12) $+    -- A legacy_version below TLS 1.2 is refused.  One above it is not: a+    -- server negotiates the highest version it supports (RFC 5246 Appendix+    -- E.1), and with supported_versions present does not use legacy_version+    -- at all (RFC 8446 Section 4.2.1).  Both are decided below.+    when (chVersion < TLS12) $         throwCore $             Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion @@ -127,10 +132,12 @@             else return (Nothing, False)     case mClientHello' of         Just chI -> do-            setupI ctx chI+            -- chI is created from diff.+            -- encodeHandshake is a MUST.+            setupI ctx chI $ [encodeHandshake $ ClientHello chI]             return (chosenVersion, chI, Just chRandom)         _ -> do-            setupO ctx ch+            setupO ctx ch b             when (chosenVersion == TLS13) $ do                 let hasECHConf = not (null (sharedECHConfigList (serverShared sparams)))                 when (hasECHConf && not receivedECH) $@@ -141,19 +148,19 @@                         setECHEE True             return (chosenVersion, ch, Nothing) -setupI :: Context -> ClientHello -> IO ()-setupI ctx chI@CH{..} = do+setupI :: Context -> ClientHello -> [ByteString] -> IO ()+setupI ctx chI@CH{..} b = do     hrr <- usingState_ ctx getTLS13HRR     unless hrr $ startHandshake ctx TLS13 chRandom-    usingHState ctx $ setClientHello chI+    usingHState ctx $ setClientHello chI b     let serverName = getServerName chExtensions     maybe (return ()) (usingState_ ctx . setClientSNI) serverName -setupO :: Context -> ClientHello -> IO ()-setupO ctx ch@CH{..} = do+setupO :: Context -> ClientHello -> [ByteString] -> IO ()+setupO ctx ch@CH{..} b = do     hrr <- usingState_ ctx getTLS13HRR     unless hrr $ startHandshake ctx chVersion chRandom-    usingHState ctx $ setClientHello ch+    usingHState ctx $ setClientHello ch b     let serverName = getServerName chExtensions     maybe (return ()) (usingState_ ctx . setClientSNI) serverName @@ -167,9 +174,20 @@         Nothing         extractServerName   where-    extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns)+    extractServerName (ServerName ns) = case mapMaybe toHostName ns of+        [] -> Nothing+        [hostName]+            | all validChar hostName -> Just hostName+            | otherwise -> illegal "invalid host_name in SNI"+        _ -> illegal "multiple host_names in SNI"     toHostName (ServerNameHostName hostName) = Just hostName     toHostName (ServerNameOther _) = Nothing+    -- RFC 6066 Section 3: the server_name_list MUST NOT contain more+    -- than one name of the same name_type, and HostName is an ASCII+    -- DNS host name, so it has no control characters, spaces nor+    -- non-ASCII bytes.+    validChar c = c > ' ' && c < '\DEL'+    illegal msg = E.throw $ Uncontextualized $ Error_Protocol msg IllegalParameter  findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions =
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -11,11 +11,12 @@ import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension+import Network.TLS.Handshake.Common (ticketOrSessionID12) import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature-import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters+import Network.TLS.Session (SessionManager (..)) import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types (CipherId (..), Role (..))@@ -33,6 +34,7 @@ processClientHello12 sparams ctx ch = do     let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams     when secureRenegotiation $ checkSecureRenegotiation ctx ch+    checkEcPointFormats ch     serverName <- usingState_ ctx getClientSNI     let hooks = serverHooks sparams     extraCreds <- onServerNameIndication hooks serverName@@ -41,19 +43,58 @@     -- The shared cipherlist can become empty after filtering for compatible     -- creds, check now before calling onCipherChoosing, which does not handle     -- empty lists.-    when (null ciphersFilteredVersion) $+    when (null ciphersFilteredVersion) $ do+        checkResumedCipherOffered ctx ch         throwCore $             Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure-    let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion+    usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion     mcred <- chooseCreds usedCipher creds signatureCreds-    void $ updateTranscriptHash12 ctx $ ClientHello ch     return (usedCipher, mcred) +-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer the+-- cipher suite of that session.  validateSession reports its absence with+-- illegal_parameter once a cipher has been chosen; when none can be chosen,+-- the same is reported here before the missing common cipher is.+checkResumedCipherOffered :: Context -> ClientHello -> IO ()+checkResumedCipherOffered ctx CH{..} = do+    let mticket =+            lookupAndDecode+                EID_SessionTicket+                MsgTClientHello+                chExtensions+                Nothing+                (\(SessionTicket ticket) -> Just ticket)+    case ticketOrSessionID12 mticket chSession of+        Nothing -> return ()+        Just identity -> do+            msd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity+            case msd of+                Just sd+                    | sessionVersion sd <= TLS12+                    , CipherId (sessionCipher sd) `notElem` chCiphers ->+                        throwCore $+                            Error_Protocol "new cipher is different from the old one" IllegalParameter+                _ -> return ()+ checkSecureRenegotiation :: Context -> ClientHello -> IO () checkSecureRenegotiation ctx CH{..} = do     -- RFC 5746: secure renegotiation     -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}-    when (CipherId 0xff `elem` chCiphers) $+    let hasSCSV = CipherId 0xff `elem` chCiphers+        hasExt = isJust $ extensionLookup EID_SecureRenegotiation chExtensions+    established <- ctxEstablished ctx+    secure <- usingState_ ctx getSecureRenegotiation+    -- RFC 5746 Section 3.7: when renegotiating a connection whose+    -- secure_renegotiation flag is set, ClientHello MUST NOT contain+    -- the SCSV and MUST contain the renegotiation_info extension.+    when (established == Established && secure) $ do+        when hasSCSV $+            throwCore $+                Error_Protocol "SCSV in renegotiation" HandshakeFailure+        unless hasExt $+            throwCore $+                Error_Protocol "no renegotiation_info in renegotiation" HandshakeFailure+    when hasSCSV $         usingState_ ctx $             setSecureRenegotiation True     case extensionLookup EID_SecureRenegotiation chExtensions of@@ -103,7 +144,7 @@      -- Cipher selection is performed in two steps: first server credentials     -- are flagged as not suitable for signature if not compatible with-    -- negotiated signature parameters.  Then ciphers are evalutated from+    -- negotiated signature parameters.  Then ciphers are evaluated from     -- the resulting credentials.      supported = serverSupported sparams@@ -172,6 +213,34 @@             Error_Protocol "key exchange algorithm not implemented" HandshakeFailure  ----------------------------------------------------------------++-- RFC 8422 Section 5.1.2: a client that names a curve of RFC 8422 in+-- supported_groups and sends ec_point_formats without the uncompressed+-- format is refused with illegal_parameter.  An empty list is refused+-- with decode_error when decoding it.+checkEcPointFormats :: ClientHello -> IO ()+checkEcPointFormats CH{..} =+    lookupAndDecodeAndDo+        EID_EcPointFormats+        MsgTClientHello+        chExtensions+        (return ())+        $ \(EcPointFormatsSupported formats) ->+            when+                ( EcPointFormat_Uncompressed `notElem` formats+                    && any (`elem` rfc8422Groups) groups+                )+                $ throwCore+                $ Error_Protocol "uncompressed point format missing" IllegalParameter+  where+    groups =+        lookupAndDecode+            EID_SupportedGroups+            MsgTClientHello+            chExtensions+            []+            (\(SupportedGroups gs) -> gs)+    rfc8422Groups = [P256, P384, P521, X25519, X448]  negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon serverGroups exts =
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -3,6 +3,7 @@  module Network.TLS.Handshake.Server.ClientHello13 (     processClientHello13,+    SelectKeyShareResult (..), ) where  import qualified Data.ByteString as B@@ -12,26 +13,30 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.IO.Encode import Network.TLS.Imports-import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types +limitSupportedGroups :: Int+limitSupportedGroups = 64+ -- TLS 1.3 or later processClientHello13     :: ServerParams     -> Context     -> ClientHello     -> IO-        ( Maybe KeyShareEntry-        , (Cipher, Hash, Bool)-        , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+        ( SelectKeyShareResult+        , (Cipher, Hash, Bool) -- rtt0+        , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+          -- authenticated, is0RTTvalid, ticket ALPN         ) processClientHello13 sparams ctx ch@CH{..} = do     when@@ -45,8 +50,8 @@     when (null ciphersFilteredVersion) $         throwCore $             Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure-    let usedCipher = onCipherChoosing (serverHooks sparams) TLS13 ciphersFilteredVersion-        usedHash = cipherHash usedCipher+    usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion+    let usedHash = cipherHash usedCipher         rtt0 =             lookupAndDecode                 EID_EarlyData@@ -73,47 +78,65 @@         extract _ = require     keyShares <-         lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract-    mshare <- findKeyShare keyShares serverGroups+    let clientGroups =+            take limitSupportedGroups $+                lookupAndDecode+                    EID_SupportedGroups+                    MsgTClientHello+                    chExtensions+                    []+                    (\(SupportedGroups gs) -> gs)+    (mgroup, doHRR) <-+        onSelectKeyShare+            (serverHooks sparams)+            serverGroups+            clientGroups+            $ map keyShareEntryGroup keyShares+    keyshareResult <- case mgroup of+        Nothing -> return SelectKeyShareNotFound+        Just g+            | doHRR -> return $ SelectKeyShareHRR g+            | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of+                [] -> return SelectKeyShareNotFound+                [x] -> return $ SelectKeyShareFound x+                _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter+     let triple = (usedCipher, usedHash, rtt0)     pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch-    clientHello <- fromJust <$> usingHState ctx getClientHello-    void $ updateTranscriptHash12 ctx $ ClientHello clientHello-    return (mshare, triple, pskEarlySecret)+    (ich, b) <- fromJust <$> usingHState ctx getClientHello+    updateTranscriptHash12 ctx (ClientHello ich, b)+    return (keyshareResult, triple, pskEarlySecret)   where     ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers     serverCiphers =         filter             (cipherAllowedForVersion TLS13)             (supportedCiphers $ serverSupported sparams)-    serverGroups = supportedGroups (ctxSupported ctx)+    serverGroups = supportedGroupsTLS13 $ serverSupported sparams -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)-findKeyShare ks ggs = go ggs-  where-    go [] = return Nothing-    go (g : gs) = case filter (grpEq g) ks of-        [] -> go gs-        [k] -> do-            unless (checkKeyShareKeyLength k) $-                throwCore $-                    Error_Protocol "broken key_share" IllegalParameter-            return $ Just k-        _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter-    grpEq g ent = g == keyShareEntryGroup ent+data SelectKeyShareResult+    = -- | Negotiation failure+      SelectKeyShareNotFound+    | -- | Send a hello retry request with this group+      SelectKeyShareHRR Group+    | -- | Use this key share+      SelectKeyShareFound KeyShareEntry+    deriving (Eq, Show)  pskAndEarlySecret     :: ServerParams     -> Context-    -> (Cipher, Hash, Bool)+    -> (Cipher, Hash, Bool) -- rtt0     -> ClientHello-    -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+    -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+    -- authenticated, is0RTTvalid, ticket ALPN pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do-    (psk, binderInfo, is0RTTvalid) <- choosePSK+    (psk, binderInfo, is0RTTvalid, ticketALPN) <- choosePSK     earlyKey <- calculateEarlySecret ctx choice (Left psk)     let earlySecret = pairBase earlyKey         authenticated = isJust binderInfo     preSharedKeyExt <- checkBinder earlySecret binderInfo-    return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid)+    return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN)   where     choice = makeCipherChoice TLS13 usedCipher @@ -122,7 +145,7 @@             EID_PreSharedKey             MsgTClientHello             chExtensions-            (return (zero, Nothing, False))+            (return (zero, Nothing, False, Nothing))             selectPSK      selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do@@ -141,33 +164,40 @@                         then sessionResumeOnlyOnce mgr identity                         else sessionResume mgr identity                 case msdata of-                    Just sdata -> do-                        let tinfo = fromJust $ sessionTicketInfo sdata-                            psk = sessionSecret sdata-                        isFresh <- checkFreshness tinfo obfAge-                        (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata-                        if isPSKvalid && isFresh-                            then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)-                            else -- fall back to full handshake-                                return (zero, Nothing, False)-                    _ -> return (zero, Nothing, False)-            else return (zero, Nothing, False)-    selectPSK _ = return (zero, Nothing, False)+                    -- RFC 8446 Section 4.6.1: only a TLS 1.3 session, which+                    -- has its ticket information, is resumed with a PSK.  A+                    -- TLS 1.2 one found under the same identity falls back+                    -- to a full handshake.+                    Just sdata+                        | sessionVersion sdata == TLS13+                        , Just tinfo <- sessionTicketInfo sdata -> do+                            let psk = sessionSecret sdata+                            isFresh <- checkFreshness tinfo obfAge+                            (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata+                            if isPSKvalid && isFresh+                                then+                                    return+                                        ( psk+                                        , Just (bnd, 0 :: Int, len)+                                        , is0RTTvalid+                                        , sessionALPN sdata+                                        )+                                else -- fall back to full handshake+                                    return (zero, Nothing, False, Nothing)+                    _ -> return (zero, Nothing, False, Nothing)+            else return (zero, Nothing, False, Nothing)+    selectPSK _ = return (zero, Nothing, False, Nothing)      checkBinder _ Nothing = return []     checkBinder earlySecret (Just (binder, n, tlen)) = do-        ch <- fromJust <$> usingHState ctx getClientHello-        let ech = encodeHandshake $ ClientHello ch-            binder' = makePSKBinder earlySecret usedHash tlen ech+        (_, b) <- fromJust <$> usingHState ctx getClientHello+        let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx         unless (binder == binder') $             decryptError "PSK binder validation failed"         return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]      checkSessionEquality sdata = do         msni <- usingState_ ctx getClientSNI-        -- ALPN should be checked.-        -- But it's an extension in EE, sigh.-        --        malpn <- usingState_ ctx getNegotiatedProtocol         let isSameSNI = sessionClientSNI sdata == msni             isSameCipher = sessionCipher sdata == cipherID usedCipher             ciphers = supportedCiphers $ serverSupported sparams@@ -176,9 +206,8 @@                 Nothing -> False                 Just c -> cipherHash c == cipherHash usedCipher             isSameVersion = TLS13 == sessionVersion sdata-            --            isSameALPN = sessionALPN sdata == malpn             isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required-            is0RTTvalid = isSameVersion && isSameCipher -- && isSameALPN+            is0RTTvalid = isSameVersion && isSameCipher         return (isPSKvalid, is0RTTvalid)      dhModes =
Network/TLS/Handshake/Server/Common.hs view
@@ -2,6 +2,7 @@  module Network.TLS.Handshake.Server.Common (     applicationProtocol,+    chooseCipher,     checkValidClientCertChain,     clientCertificate,     credentialDigitalSignatureKey,@@ -15,8 +16,9 @@ ) where  import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Credentials import Network.TLS.Crypto@@ -32,6 +34,18 @@ import Network.TLS.Util (catchException) import Network.TLS.X509 +chooseCipher :: ServerHooks -> Version -> [Cipher] -> IO Cipher+chooseCipher hooks ver candidates =+    case find ((== cipherID selected) . cipherID) candidates of+        Just cipher -> return cipher+        Nothing ->+            throwCore $+                Error_Protocol+                    "onCipherChoosing selected a cipher outside the candidate list"+                    InternalError+  where+    selected = onCipherChoosing hooks ver candidates+ checkValidClientCertChain     :: MonadIO m => Context -> String -> m CertificateChain checkValidClientCertChain ctx errmsg = do@@ -132,6 +146,11 @@         when (proto == "") $             throwCore $                 Error_Protocol "no supported application protocols" NoApplicationProtocol+        unless (proto `elem` protos) $+            throwCore $+                Error_Protocol+                    "ALPN callback selected a protocol not offered by the client"+                    NoApplicationProtocol         usingState_ ctx $ do             setExtensionALPN True             setNegotiatedProtocol proto@@ -151,7 +170,9 @@                 (onClientCertificate (serverHooks sparams) certs)                 rejectOnException     case usage of-        CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+        CertificateUsageAccept -> do+            verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+            verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs         CertificateUsageReject reason -> certificateRejected reason      -- Remember cert chain for later use.
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -5,6 +5,8 @@     sendServerHello12, ) where +import Data.ByteArray (convert)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -42,7 +44,7 @@             sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession             build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions             let ff = ServerHello sh : build [ServerHelloDone]-            sendPacket12 ctx $ Handshake ff+            sendPacket12 ctx $ Handshake ff []             contextFlush ctx         Just sessionData -> do             usingState_ ctx $ do@@ -50,8 +52,8 @@                 setTLS12SessionResuming True             sh <-                 makeServerHello sparams ctx usedCipher mcred chExtensions chSession-            sendPacket12 ctx $ Handshake [ServerHello sh]-            let mainSecret = sessionSecret sessionData+            sendPacket12 ctx $ Handshake [ServerHello sh] []+            let mainSecret = convert $ sessionSecret sessionData             usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret             logKey ctx $ MainSecret mainSecret             sendCCSandFinished ctx ServerRole@@ -91,7 +93,7 @@     | TLS12 < sessionVersion sd = return Nothing -- fixme     | CipherId (sessionCipher sd) `notElem` ciphers =         throwCore $-            Error_Protocol "new cipher is diffrent from the old one" IllegalParameter+            Error_Protocol "new cipher is different from the old one" IllegalParameter     | isJust sni && sessionClientSNI sd /= sni = do         usingState_ ctx clearClientSNI         return Nothing@@ -141,7 +143,7 @@         then do             let (certTypes, hashSigs) =                     let as = supportedHashSignatures serverSupported-                     in (nub $ mapMaybe hashSigToCertType as, as)+                     in (nub $ mapMaybe (fmap certTypeOnWire . hashSigToCertType) as, as)                 creq =                     CertRequest                         certTypes@@ -151,6 +153,12 @@             return $ b2 . (creq :)         else return b2   where+    -- RFC 8422 Section 3.1: in TLS 1.2, ecdsa_sign asks for a certificate+    -- with an ECDSA- or EdDSA-capable public key.  The Ed25519 and Ed448+    -- certificate types are synthetic values with no code point.+    certTypeOnWire CertificateType_Ed25519_Sign = CertificateType_ECDSA_Sign+    certTypeOnWire CertificateType_Ed448_Sign = CertificateType_ECDSA_Sign+    certTypeOnWire t = t     commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts     commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts     setup_DHE = do@@ -202,10 +210,10 @@      setup_ECDHE grp = do         usingHState ctx $ setSupportedGroup grp-        (srvpri, srvpub) <- generateECDHE ctx grp+        (srvpri, srvpub) <- generateGroup ctx grp         let serverParams = ServerECDHParams grp srvpub         usingHState ctx $ setServerECDHParams serverParams-        usingHState ctx $ setGroupPrivate srvpri+        usingHState ctx $ setGroupPrivate [(grp, srvpri)]         return serverParams      generateSKX_ECDHE kxsAlg = do@@ -265,9 +273,13 @@             | ems = Just $ toExtensionRaw ExtendedMainSecret             | otherwise = Nothing +    -- RFC 5077 Section 3.2: the extension is sent only to a client that+    -- sent it.     let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams+        clientTicket = isJust $ extensionLookup EID_SessionTicket chExts         sessionTicketExt-            | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket ""+            | not resuming && useTicket && clientTicket =+                Just $ toExtensionRaw $ SessionTicket ""             | otherwise = Nothing      -- in TLS12, we need to check as well the certificates we are sending if they have in the extension
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -36,17 +36,18 @@     :: ServerParams     -> Context     -> KeyShareEntry-    -> (Cipher, Hash, Bool)-    -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)+    -> (Cipher, Hash, Bool) -- rtt0+    -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)+    -- authenticated, is0RTTvalid, ticket ALPN     -> ClientHello     -> Maybe ClientRandom     -> IO         ( SecretTriple ApplicationSecret         , ClientTrafficSecret HandshakeSecret-        , Bool-        , Bool+        , Bool -- authenticated+        , Bool -- rtt0OK         )-sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do+sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN) CH{..} mOuterClientRandom = do     let clientEarlySecret = pairClient earlyKey         earlySecret = pairBase earlyKey     -- parse CompressCertificate to check if it is broken here@@ -69,8 +70,15 @@         setOuterClientRandom mOuterClientRandom     hrr <- usingState_ ctx getTLS13HRR     alpnExt <- applicationProtocol ctx chExtensions sparams+    negotiatedALPN <- usingState_ ctx getNegotiatedProtocol     setServerParameter-    let rtt0OK = authenticated && not hrr && rtt0 && rtt0accept && is0RTTvalid+    let rtt0OK =+            authenticated+                && not hrr+                && rtt0+                && rtt0accept+                && is0RTTvalid+                && ticketALPN == negotiatedALPN     extraCreds <-         usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)     let p = makeCredentialPredicate TLS13 chExtensions@@ -120,7 +128,7 @@             Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib         let ServerTrafficSecret shs = serverHandshakeSecret         rawFinished <- makeFinished ctx usedHash shs-        loadPacket13 ctx $ Handshake13 [rawFinished]+        loadPacket13 ctx $ Handshake13 [rawFinished] []         return (clientHandshakeSecret, handSecret)     ----------------------------------------------------------------     hChSf <- transcriptHash ctx "CH..SF"@@ -204,7 +212,7 @@                             , shExtensions = shExts                             }                 usingHState ctx $ setECHAccepted True-                loadPacket13 ctx $ Handshake13 [ServerHello13 sh']+                loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] []             else do                 srand <-                     liftIO $@@ -220,26 +228,26 @@                             , shComp = 0                             , shExtensions = shExts                             }-                loadPacket13 ctx $ Handshake13 [ServerHello13 sh]+                loadPacket13 ctx $ Handshake13 [ServerHello13 sh] []      sendCertAndVerify cred@(certChain, _) hashSig zlib = do         storePrivInfoServer ctx cred         when (serverWantClientCert sparams) $ do             let certReqCtx = "" -- this must be zero length here.                 certReq = makeCertRequest sparams ctx certReqCtx True-            loadPacket13 ctx $ Handshake13 [certReq]+            loadPacket13 ctx $ Handshake13 [certReq] []             usingHState ctx $ setCertReqSent True          let CertificateChain cs = certChain             ess = replicate (length cs) []         let certtag = if zlib then CompressedCertificate13 else Certificate13         loadPacket13 ctx $-            Handshake13 [certtag "" (CertificateChain_ certChain) ess]+            Handshake13 [certtag "" (CertificateChain_ certChain) ess] []         liftIO $ usingState_ ctx $ setServerCertificateChain certChain         hChSc <- transcriptHash ctx "CH..SC"         pubkey <- getLocalPublicKey ctx         vrfy <- makeCertVerify ctx pubkey hashSig hChSc-        loadPacket13 ctx $ Handshake13 [vrfy]+        loadPacket13 ctx $ Handshake13 [vrfy] []      sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do         msni <- liftIO $ usingState_ ctx getClientSNI@@ -285,7 +293,7 @@                         ]         eeExtensions' <-             liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions-        loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions']+        loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] []  credentialsFindForSigning13     :: [HashAndSignatureAlgorithm]@@ -313,34 +321,19 @@  ---------------------------------------------------------------- -sendHRR :: Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()-sendHRR ctx (usedCipher, usedHash, _) CH{..} isEch = do+sendHRR :: Context -> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()+sendHRR ctx g (usedCipher, usedHash, _) CH{..} isEch = do     twice <- usingState_ ctx getTLS13HRR     when twice $         throwCore $             Error_Protocol "Hello retry not allowed again" HandshakeFailure     usingState_ ctx $ setTLS13HRR True     failOnEitherError $ setServerHelloParameters13 ctx usedCipher True-    let clientGroups =-            lookupAndDecode-                EID_SupportedGroups-                MsgTClientHello-                chExtensions-                []-                (\(SupportedGroups gs) -> gs)-        possibleGroups = serverGroups `intersect` clientGroups-    case possibleGroups of-        [] ->-            throwCore $-                Error_Protocol "no group in common with the client for HRR" HandshakeFailure-        g : _ -> do-            hrr <- makeHRR ctx usedCipher usedHash chSession g isEch-            usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest-            runPacketFlight ctx $ do-                loadPacket13 ctx $ Handshake13 [ServerHello13 hrr]-                sendChangeCipherSpec13 ctx-  where-    serverGroups = supportedGroups (ctxSupported ctx)+    hrr <- makeHRR ctx usedCipher usedHash chSession g isEch+    usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+    runPacketFlight ctx $ do+        loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] []+        sendChangeCipherSpec13 ctx  makeHRR     :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello
Network/TLS/Handshake/Server/TLS12.hs view
@@ -5,10 +5,12 @@ ) where  import Control.Monad.State.Strict (gets)+import Data.ByteArray (convert) import qualified Data.ByteString as B  import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Extension import Network.TLS.Handshake.Common import Network.TLS.Handshake.Key import Network.TLS.Handshake.Server.Common@@ -36,11 +38,17 @@         Nothing -> do             recvClientCCC sparams ctx             mticket <- sessionEstablished ctx+            -- RFC 5077 Section 3.3: NewSessionTicket is sent only after+            -- the session_ticket extension in ServerHello, which only a+            -- client that sent it gets.+            clientTicket <-+                maybe False (isJust . extensionLookup EID_SessionTicket . chExtensions . fst)+                    <$> usingHState ctx getClientHello             case mticket of-                Nothing -> return ()-                Just ticket -> do+                Just ticket | clientTicket -> do                     let life = adjustLifetime $ serverTicketLifetime sparams-                    sendPacket12 ctx $ Handshake [NewSessionTicket life ticket]+                    sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] []+                _ -> return ()             sendCCSandFinished ctx ServerRole         Just _ -> do             _ <- sessionEstablished ctx@@ -91,7 +99,11 @@         -- matches our request and that we support         -- verifying with that certificate. -        return $ RecvStateHandshake $ expectClientKeyExchange True+        -- RFC 5246 Section 7.4.8: CertificateVerify follows only a+        -- certificate with signing capability, so not an empty one,+        -- which the hook may have accepted.+        let followedCertVerify = not $ isNullCertificateChain certs+        return $ RecvStateHandshake $ expectClientKeyExchange followedCertVerify     expectClientCertificate p = expectClientKeyExchange False p      -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,@@ -142,10 +154,11 @@             -- BadRecordMac is nonsense but for tlsfuzzer             throwCore $                 Error_Protocol "invalid client public key" BadRecordMac-        Right preMain -> case decodePreMainSecret preMain of-            Left _ -> usingHState ctx $ setMainSecretFromPre rver role random+        Right preMain -> case decodePreMainSecret $ convert preMain of+            Left _ -> usingHState ctx $ setMainSecretFromPre rver role $ convert random             Right (ver, _)-                | ver /= expectedVer -> usingHState ctx $ setMainSecretFromPre rver role random+                | ver /= expectedVer ->+                    usingHState ctx $ setMainSecretFromPre rver role $ convert random                 | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain     logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do@@ -164,21 +177,23 @@     logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do     ServerECDHParams grp _ <- usingHState ctx getServerECDHParams-    case decodeGroupPublic grp bytes of+    case groupDecodePublicB grp bytes of         Left _ ->             throwCore $                 Error_Protocol "client public key cannot be decoded" IllegalParameter         Right clipub -> do-            srvpri <- usingHState ctx getGroupPrivate-            case groupGetShared clipub srvpri of-                Just preMain -> do-                    rver <- usingState_ ctx getVersion-                    role <- usingState_ ctx getRole-                    mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain-                    logKey ctx (MainSecret mainSecret)-                Nothing ->-                    throwCore $-                        Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter+            grpSpris <- usingHState ctx getGroupPrivate+            case lookup grp grpSpris of+                Nothing -> throwCore err+                Just srvpri -> case groupDecapsulate clipub srvpri of+                    Just preMain -> do+                        rver <- usingState_ ctx getVersion+                        role <- usingState_ ctx getRole+                        mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain+                        logKey ctx (MainSecret mainSecret)+                    Nothing -> throwCore err+  where+    err = Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter  ----------------------------------------------------------------
Network/TLS/Handshake/Server/TLS13.hs view
@@ -9,9 +9,8 @@     KeyUpdateRequest (..), ) where -import Control.Exception+import qualified Control.Exception as E import Control.Monad.State.Strict-import qualified Data.ByteString.Char8 as C8 import Data.IORef  import Network.TLS.Cipher@@ -29,6 +28,7 @@ import Network.TLS.IO import Network.TLS.Imports import Network.TLS.KeySchedule+import Network.TLS.Packet13 (encodeHandshake13) import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State@@ -71,7 +71,7 @@                 then                     setPendingRecvActions                         ctx-                        [ PendingRecvAction True True $ expectEndOfEarlyData ctx clientHandshakeSecret+                        [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret                         , PendingRecvActionHash True $                             expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime                         ]@@ -104,7 +104,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13")  expectEndOfEarlyData-    :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO ()+    :: Context+    -> ClientTrafficSecret HandshakeSecret+    -> Handshake13+    -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do     (usedHash, usedCipher, _, _) <- getRxRecordState ctx     setRxRecordState ctx usedHash usedCipher clientHandshakeSecret@@ -145,7 +148,7 @@         psk = derivePSK choice resumptionSecret nonce     (identity, add) <- generateSession life psk rtt0max rtt     let nst = createNewSessionTicket life add nonce identity rtt0max-    sendPacket13 ctx $ Handshake13 [nst]+    sendPacket13 ctx $ Handshake13 [nst] []   where     choice = makeCipherChoice TLS13 usedCipher     rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams@@ -179,7 +182,8 @@         | otherwise = fromIntegral i  expectCertVerify-    :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m ()+    :: MonadIO m+    => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do     certs@(CertificateChain cc) <-         checkValidClientCertChain ctx "invalid client certificate chain"@@ -236,27 +240,31 @@         origCertReqCtx <- newCertReqContext ctx         let certReq13 = makeCertRequest sparams ctx origCertReqCtx False         _ <- withWriteLock ctx $ do-            bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do-                sendPacket13 ctx $ Handshake13 [certReq13]+            E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do+                sendPacket13 ctx $ Handshake13 [certReq13] []         withReadLock ctx $ do-            clientCert13 <- getHandshake ctx ref-            emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13             baseHState <- saveHState ctx-            void $ updateTranscriptHash13 ctx certReq13-            void $ updateTranscriptHash13 ctx clientCert13+            -- RFC 8446 Section 4.4: the handshake context of+            -- post-handshake authentication is ClientHello ... client+            -- Finished + CertificateRequest.+            updateTranscriptHash13 ctx (certReq13, [encodeHandshake13 certReq13])+            (clientCert13, bClientCert13) <- getHandshake ctx ref+            emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13+            updateTranscriptHash13 ctx (clientCert13, bClientCert13)             th <- transcriptHash ctx "CH..Cert"             unless emptyCert $ do-                certVerify13 <- getHandshake ctx ref+                (certVerify13, bCertVerify13) <- getHandshake ctx ref                 expectCertVerify sparams ctx th certVerify13-                void $ updateTranscriptHash13 ctx certVerify13-            finished13 <- getHandshake ctx ref+                updateTranscriptHash13 ctx (certVerify13, bCertVerify13)+            (finished13, _bFinished13) <- getHandshake ctx ref             expectClientFinished ctx finished13             void $ restoreHState ctx baseHState -- fixme         return True  -- saving appdata and key update? -- error handling-getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13+getHandshake+    :: Context -> IORef [Handshake13R] -> IO Handshake13R getHandshake ctx ref = do     hhs <- readIORef ref     if null hhs@@ -265,23 +273,30 @@             either (terminate ctx) process ex         else chk hhs   where-    process (Handshake13 iss) = chk iss+    process (Handshake13 hss bss) = chk $ zip hss bss     process _ =         terminate ctx $             Error_Protocol "post handshake authenticated" UnexpectedMessage     chk [] = getHandshake ctx ref-    chk (KeyUpdate13 mode : hs) = do+    chk ((KeyUpdate13 mode, _) : hbs) = do+        case limitKeyUpdate $ sharedLimit $ ctxShared ctx of+            Just limit | limit > 0 -> do+                count <- incrementTLS13KeyUpdateCount ctx+                when (count > limit) $+                    terminate ctx $+                        Error_Protocol "too many consecutive KeyUpdate messages" UnexpectedMessage+            _ -> return ()         keyUpdate ctx getRxRecordState setRxRecordState         -- Write lock wraps both actions because we don't want another         -- packet to be sent by another thread before the Tx state is         -- updated.         when (mode == UpdateRequested) $ withWriteLock ctx $ do-            sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested]+            sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] []             keyUpdate ctx getTxRecordState setTxRecordState-        chk hs-    chk (h : hs) = do-        writeIORef ref hs-        return h+        chk hbs+    chk (hb : hbs) = do+        writeIORef ref hbs+        return hb  expectClientCertificate     :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool@@ -325,25 +340,25 @@         send = sendPacket13 ctx . Alert13     catchException (send [(level, desc)]) (\_ -> return ())     setEOF ctx-    throwIO $ Terminated False reason err+    E.throwIO $ Terminated False reason err  handleEx :: Context -> IO Bool -> IO Bool handleEx ctx f = catchException f $ \exception -> do     -- If the error was an Uncontextualized TLSException, we replace the     -- context with HandshakeFailed. If it's anything else, we convert     -- it to a string and wrap it with Error_Misc and HandshakeFailed.-    let tlserror = case fromException exception of+    let tlserror = case E.fromException exception of             Just e | Uncontextualized e' <- e -> e'             _ -> Error_Misc (show exception)     sendPacket13 ctx $ Alert13 [errorToAlert tlserror]-    void $ throwIO $ PostHandshake tlserror+    void $ E.throwIO $ PostHandshake tlserror     return False  ----------------------------------------------------------------  keyUpdate     :: Context-    -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))+    -> (Context -> IO (Hash, Cipher, CryptLevel, Secret))     -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ())     -> IO () keyUpdate ctx getState setState = do@@ -366,7 +381,7 @@       TwoWay     deriving (Eq, Show) --- | Updating appication traffic secrets for TLS 1.3.+-- | Updating application traffic secrets for TLS 1.3. --   If this API is called for TLS 1.3, 'True' is returned. --   Otherwise, 'False' is returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool@@ -379,6 +394,6 @@         -- Write lock wraps both actions because we don't want another packet to         -- be sent by another thread before the Tx state is updated.         withWriteLock ctx $ do-            sendPacket13 ctx $ Handshake13 [KeyUpdate13 req]+            sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] []             keyUpdate ctx getTxRecordState setTxRecordState     return tls13
Network/TLS/Handshake/Signature.hs view
@@ -60,6 +60,25 @@ signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True signatureCompatible _ (_, _) = False +-- Whether the signature algorithm is for the type of the key, whatever+-- its other parameters.+keyTypeFits :: PubKey -> SignatureAlgorithm -> Bool+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 _ _ = False+ -- 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@@ -118,9 +137,21 @@     -> ByteString     -> DigitallySigned     -> IO Bool-checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _)-    | pubKey `signatureCompatible` hashSigAlg = doVerify-    | otherwise = return False+-- An algorithm not offered in CertificateRequest (RFC 5246 Section+-- 7.4.8), or one for another type of key, is a field that is incorrect,+-- an illegal_parameter.  One for the right type of key that still does+-- not fit it, an RSASSA-PSS one for an rsaEncryption key say, is a+-- signature that does not verify, a decrypt_error, which False leads to.+checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg@(_, sigAlg) _) = do+    checkSupportedHashSignature ctx hashSigAlg+    unless (pubKey `keyTypeFits` sigAlg) $+        throwCore $+            Error_Protocol+                ("signature algorithm " ++ show hashSigAlg ++ " is for another type of key")+                IllegalParameter+    if pubKey `signatureCompatible` hashSigAlg+        then doVerify+        else return False   where     doVerify =         prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs
Network/TLS/Handshake/State.hs view
@@ -81,7 +81,7 @@ ) where  import Control.Monad.State.Strict-import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray (convert) import Data.X509 (CertificateChain)  import Network.TLS.Cipher@@ -104,7 +104,7 @@     = -- | Initial state       TransHashState0     | -- | A raw CH is stored since hash algo is not chosen yet.-      TransHashState1 ByteString+      TransHashState1 [ByteString]     | -- | Hashed       TransHashState2 HashCtx @@ -120,12 +120,12 @@     , hstClientRandom :: ClientRandom     -- ^ For ECH, inner client random.     , hstServerRandom :: Maybe ServerRandom-    , hstMainSecret :: Maybe ByteString+    , hstMainSecret :: Maybe Secret     , hstKeyState :: HandshakeKeyState     , hstServerDHParams :: Maybe ServerDHParams     , hstDHPrivate :: Maybe DHPrivate     , hstServerECDHParams :: Maybe ServerECDHParams-    , hstGroupPrivate :: Maybe GroupPrivate+    , hstGroupPrivate :: [(Group, GroupPrivate)]     , hstTransHashState :: TransHashState     , hstTransHashStateI :: TransHashState -- Inner CH for client ECH     , hstHandshakeMessages :: [ByteString]@@ -161,7 +161,7 @@     , hstCCS13Recv :: Bool     , hstTLS13OuterClientRandom :: Maybe ClientRandom     -- ^ Used for key logging in the case of ECH.-    , hstTLS13ClientHello :: Maybe ClientHello+    , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString])     -- ^ Inner client hello in the case of ECH.     , hstTLS13ECHAccepted :: Bool     , hstTLS13ECHEE :: Bool@@ -236,7 +236,7 @@         , hstServerDHParams = Nothing         , hstDHPrivate = Nothing         , hstServerECDHParams = Nothing-        , hstGroupPrivate = Nothing+        , hstGroupPrivate = []         , hstTransHashState = TransHashState0         , hstTransHashStateI = TransHashState0         , hstHandshakeMessages = []@@ -303,11 +303,11 @@ getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate-getGroupPrivate = fromJust <$> gets hstGroupPrivate+getGroupPrivate :: HandshakeM [(Group, GroupPrivate)]+getGroupPrivate = gets hstGroupPrivate -setGroupPrivate :: GroupPrivate -> HandshakeM ()-setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = Just shp})+setGroupPrivate :: [(Group, GroupPrivate)] -> HandshakeM ()+setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = shp})  setExtendedMainSecret :: Bool -> HandshakeM () setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b})@@ -403,11 +403,11 @@ setOuterClientRandom :: Maybe ClientRandom -> HandshakeM () setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr}) -getClientHello :: HandshakeM (Maybe ClientHello)+getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString])) getClientHello = gets hstTLS13ClientHello -setClientHello :: ClientHello -> HandshakeM ()-setClientHello ch = modify' $ \hst -> hst{hstTLS13ClientHello = Just ch}+setClientHello :: ClientHello -> [ByteString] -> HandshakeM ()+setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)}  getECHAccepted :: HandshakeM Bool getECHAccepted = gets hstTLS13ECHAccepted@@ -463,14 +463,13 @@  -- | Generate the main secret from the pre-main secret. setMainSecretFromPre-    :: ByteArrayAccess preMain-    => Version+    :: Version     -- ^ chosen transmission version     -> Role     -- ^ the role (Client or Server) of the generating side-    -> preMain+    -> Secret     -- ^ the pre-main secret-    -> HandshakeM ByteString+    -> HandshakeM Secret setMainSecretFromPre ver role preMainSecret = do     ems <- getExtendedMainSecret     secret <- if ems then get >>= genExtendedSecret else genSecret <$> get@@ -499,7 +498,7 @@  -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state.-setMainSecret :: Version -> Role -> ByteString -> HandshakeM ()+setMainSecret :: Version -> Role -> Secret -> HandshakeM () setMainSecret ver role mainSecret = modify' $ \hst ->     let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role      in hst@@ -509,7 +508,7 @@             }  computeKeyBlock-    :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState)+    :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx)   where     cipher = fromJust $ hstPendingCipher hst@@ -538,13 +537,13 @@     cstClient =         CryptState             { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey-            , cstIV = cWriteIV+            , cstIV = convert $ cWriteIV             , cstMacSecret = cMACSecret             }     cstServer =         CryptState             { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey-            , cstIV = sWriteIV+            , cstIV = convert $ sWriteIV             , cstMacSecret = sMACSecret             }     msClient = MacState{msSequence = 0}
Network/TLS/Handshake/State13.hs view
@@ -31,16 +31,16 @@ import Network.TLS.Record.State import Network.TLS.Types -getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getRxRecordState ctx = getXState ctx ctxRxRecordState  getXState     :: Context     -> (Context -> MVar RecordState)-    -> IO (Hash, Cipher, CryptLevel, ByteString)+    -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do     tx <- readMVar (func ctx)     let usedCipher = fromJust $ stCipher tx@@ -66,7 +66,7 @@     return $ stCryptLevel tx  class TrafficSecret ty where-    fromTrafficSecret :: ty -> (CryptLevel, ByteString)+    fromTrafficSecret :: ty -> (CryptLevel, Secret)  instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where     fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s)@@ -103,7 +103,7 @@     -> Hash     -> Cipher     -> CryptLevel-    -> ByteString+    -> Secret     -> IO () setXState' func encOrDec ctx h cipher lvl secret =     modifyMVar_ (func ctx) (\_ -> return rt)
Network/TLS/Handshake/TranscriptHash.hs view
@@ -40,11 +40,11 @@ transit :: String -> Hash -> Bool -> TransHashState -> TransHashState transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0 transit _ _ _ st2@(TransHashState2 _) = st2-transit _ hashAlg isHRR (TransHashState1 ch)-    | isHRR = TransHashState2 $ newWith hsMsg-    | otherwise = TransHashState2 $ newWith ch+transit _ hashAlg isHRR (TransHashState1 chs)+    | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg+    | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch   where-    newWith = hashUpdate $ hashInit hashAlg+    ch = reverse chs     hsMsg =         -- Handshake message:         -- typ <-len-> body@@ -55,7 +55,7 @@             , hashedCH             ]       where-        hashedCH = hash hashAlg ch+        hashedCH = hashChunks hashAlg ch         len = fromIntegral $ B.length hashedCH  ----------------------------------------------------------------@@ -73,9 +73,9 @@     traceTranscriptHash ctx label hstTransHashStateI  update :: ByteString -> String -> TransHashState -> TransHashState-update eh _ TransHashState0 = TransHashState1 eh+update eh _ TransHashState0 = TransHashState1 [eh]+update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss) update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh-update _ label st = error $ "updateTranscriptHash " ++ label ++ " " ++ show st  ----------------------------------------------------------------
Network/TLS/IO.hs view
@@ -16,7 +16,7 @@     loadPacket13, ) where -import Control.Exception (finally, throwIO)+import qualified Control.Exception as E import Control.Monad.Reader import Control.Monad.State.Strict import qualified Data.ByteString as B@@ -102,8 +102,15 @@             Left err -> do                 logPacket ctx $ show err                 return $ Left err-            Right record-                | hrr && isCCS record -> loop (count + 1)+            Right record@(Record _ _ fragment)+                -- the ChangeCipherSpec after a HelloRetryRequest is skipped,+                -- but checked like any other+                | hrr && isCCS record ->+                    case checkChangeCipherSpec fragment of+                        Left err -> do+                            logPacket ctx $ show err+                            return $ Left err+                        Right _ -> loop (count + 1)                 | otherwise -> do                     pktRecv <- decodePacket12 ctx record                     if isEmptyHandshake pktRecv@@ -114,9 +121,10 @@                             -- stHandshakeRecordCont                             loop (count + 1)                         else case pktRecv of-                            Right (Handshake hss) -> do-                                pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->-                                    Right . Handshake <$> mapM (hookRecvHandshake hooks) hss+                            Right (Handshake hss bss) -> do+                                pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+                                    hss' <- mapM (hookRecvHandshake hooks) hss+                                    return $ Right $ Handshake hss' bss                                 logPacket ctx $ show pkt                                 return pktRecv'                             Right pkt -> do@@ -131,7 +139,7 @@ isCCS _ = False  isEmptyHandshake :: Either TLSError Packet -> Bool-isEmptyHandshake (Right (Handshake [])) = True+isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False  logPacket :: Context -> String -> IO ()@@ -174,11 +182,15 @@                         loop (count + 1)                     else do                         case pktRecv of-                            Right (Handshake13 hss) -> do-                                pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks ->-                                    Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss+                            Right (Handshake13 hss bss) -> do+                                pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do+                                    hss' <- mapM (hookRecvHandshake13 hooks) hss+                                    return $ Right $ Handshake13 hss' bss                                 logPacket ctx $ show pkt                                 return pktRecv'+                            Right pkt@(AppData13 _) -> do+                                logPacket ctx $ show pkt+                                checkNotInterleaved ctx pktRecv                             Right pkt -> do                                 logPacket ctx $ show pkt                                 return pktRecv@@ -187,23 +199,41 @@                                 return pktRecv  isEmptyHandshake13 :: Either TLSError Packet13 -> Bool-isEmptyHandshake13 (Right (Handshake13 [])) = True+isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False  ---------------------------------------------------------------- +-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with+-- other record types.  Application data that arrives while a handshake+-- message is still incomplete is refused with unexpected_message rather+-- than delivered.  TLS 1.3 only: RFC 5246 Section 6.2.1 lets TLS 1.2+-- interleave data of different content types.+checkNotInterleaved :: Context -> Either TLSError a -> IO (Either TLSError a)+checkNotInterleaved ctx pktRecv = do+    complete <- isRecvComplete ctx+    if complete+        then return pktRecv+        else do+            let err =+                    Error_Packet_unexpected+                        "application data"+                        " expected: the rest of a handshake message"+            logPacket ctx $ show err+            return $ Left err+ isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do     cont12 <- gets stHandshakeRecordCont12     cont13 <- gets stHandshakeRecordCont13-    return $ isNothing cont12 && isNothing cont13+    return $ isNothing (fst cont12) && isNothing (fst cont13)  checkValid :: Context -> IO () checkValid ctx = do     established <- ctxEstablished ctx-    when (established == NotEstablished) $ throwIO ConnectionNotEstablished+    when (established == NotEstablished) $ E.throwIO ConnectionNotEstablished     eofed <- ctxEOF ctx-    when eofed $ throwIO $ PostHandshake Error_EOF+    when eofed $ E.throwIO $ PostHandshake Error_EOF  ---------------------------------------------------------------- @@ -221,7 +251,8 @@ runPacketFlight :: Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a runPacketFlight ctx@Context{ctxRecordLayer = recordLayer} (PacketFlightM f) = do     ref <- newIORef id-    runReaderT f (recordLayer, ref) `finally` sendPendingFlight ctx recordLayer ref+    runReaderT f (recordLayer, ref)+        `E.finally` sendPendingFlight ctx recordLayer ref  sendPendingFlight     :: Monoid b => Context -> RecordLayer b -> IORef (Builder b) -> IO ()
Network/TLS/IO/Decode.hs view
@@ -3,10 +3,12 @@ module Network.TLS.IO.Decode (     decodePacket12,     decodePacket13,+    checkChangeCipherSpec, ) where  import Control.Concurrent.MVar import Control.Monad.State.Strict+import qualified Data.ByteString as BS  import Network.TLS.Cipher import Network.TLS.Context.Internal@@ -19,6 +21,7 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13+import Network.TLS.Types (Role (..)) import Network.TLS.Util import Network.TLS.Wire @@ -26,38 +29,69 @@ decodePacket12 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment decodePacket12 _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket12 ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =-    case decodeChangeCipherSpec $ fragmentGetBytes fragment of+    case checkChangeCipherSpec fragment of         Left err -> return $ Left err         Right _ -> do-            switchRxEncryption ctx-            return $ Right ChangeCipherSpec+            -- ChangeCipherSpec comes between complete handshake messages+            -- (RFC 5246 Section 7.1), so not before the first ClientHello+            -- of a server, which has no handshake state yet, nor in the+            -- middle of a fragmented handshake message (CVE-2004-0079).+            mhs <- getHState ctx+            (mCont, _) <- usingState_ ctx $ gets stHandshakeRecordCont12+            if isNothing mhs || isJust mCont+                then+                    return $+                        Left $+                            Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake"+                else do+                    switchRxEncryption ctx+                    return $ Right ChangeCipherSpec decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do-    keyxchg <--        getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)+    mhs <- getHState ctx+    let keyxchg = mhs >>= hstPendingCipher >>= Just . cipherKeyExchange     usingState ctx $ do+        role <- getRole         let currentParams =                 CurrentParams                     { cParamsVersion = ver                     , cParamsKeyXchgType = keyxchg                     }+            -- A server has no handshake state until its first ClientHello,+            -- and that is the only message it may receive then (RFC 8446+            -- Section 4).  Any other is answered with unexpected_message+            -- before its body is decoded, rather than with whatever decoding+            -- the body as that type gives.+            expectClientHello = role == ServerRole && isNothing mhs+            decode ty content+                | expectClientHello && ty /= HandshakeType_ClientHello =+                    Left $ Error_Packet_unexpected (show ty) " expected: client hello"+                | otherwise = decodeHandshake currentParams ty content         -- get back the optional continuation, and parse as many handshake record as possible.-        mCont <- gets stHandshakeRecordCont12-        modify' (\st -> st{stHandshakeRecordCont12 = Nothing})-        hss <- parseMany currentParams mCont (fragmentGetBytes fragment)-        return $ Handshake hss+        (mCont, wirebytes) <- gets stHandshakeRecordCont12+        modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])})+        (hss, bss) <-+            unzip <$> parseMany decode mCont wirebytes (fragmentGetBytes fragment)+        return $ Handshake hss bss   where-    parseMany currentParams mCont bs =+    parseMany decode mCont wirebytes bs =         case fromMaybe decodeHandshakeRecord mCont bs of             GotError err -> throwError err-            GotPartial cont ->-                modify' (\st -> st{stHandshakeRecordCont12 = Just cont}) >> return []+            GotPartial cont -> do+                modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)})+                return []             GotSuccess (ty, content) ->-                either throwError (return . (: [])) $ decodeHandshake currentParams ty content+                case decode ty content of+                    Left err -> throwError err+                    Right h -> return [(h, reverse (bs : wirebytes))]             GotSuccessRemaining (ty, content) left ->-                case decodeHandshake currentParams ty content of+                case decode ty content of                     Left err -> throwError err-                    Right hh -> (hh :) <$> parseMany currentParams Nothing left-decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+                    Right h -> do+                        hbs <- parseMany decode Nothing [] left+                        let len = BS.length bs - BS.length left+                            bs' = BS.take len bs+                        return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty  switchRxEncryption :: Context -> IO () switchRxEncryption ctx =@@ -68,26 +102,49 @@  decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =-    case decodeChangeCipherSpec $ fragmentGetBytes fragment of+    case checkChangeCipherSpec fragment of         Left err -> return $ Left err         Right _ -> return $ Right ChangeCipherSpec13 decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do-    mCont <- gets stHandshakeRecordCont13-    modify' (\st -> st{stHandshakeRecordCont13 = Nothing})-    hss <- parseMany mCont (fragmentGetBytes fragment)-    return $ Handshake13 hss+    (mCont, wirebytes) <- gets stHandshakeRecordCont13+    modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])})+    (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment)+    return $ Handshake13 hss bss   where-    parseMany mCont bs =+    parseMany mCont wirebytes bs =         case fromMaybe decodeHandshakeRecord13 mCont bs of             GotError err -> throwError err-            GotPartial cont ->-                modify' (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return []+            GotPartial cont -> do+                modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)})+                return []             GotSuccess (ty, content) ->-                either throwError (return . (: [])) $ decodeHandshake13 ty content+                case decodeHandshake13 ty content of+                    Left err -> throwError err+                    Right h -> return [(h, reverse (bs : wirebytes))]             GotSuccessRemaining (ty, content) left ->                 case decodeHandshake13 ty content of                     Left err -> throwError err-                    Right hh -> (hh :) <$> parseMany Nothing left-decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+                    Right h -> do+                        hbs <- parseMany Nothing [] left+                        let len = BS.length bs - BS.length left+                            bs' = BS.take len bs+                        return ((h, reverse (bs' : wirebytes)) : hbs)+decodePacket13 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty++-- RFC 8446 Section 5: a record of an unexpected type, including the inner+-- type of a TLS 1.3 record, is answered with unexpected_message.+unknownProtocolType :: ProtocolType -> TLSError+unknownProtocolType ty = Error_Packet_unexpected (show ty) " expected: TLS record type"++-- | A ChangeCipherSpec is the single byte 1.  RFC 8446 Section 5 answers any+-- other value with unexpected_message, and TLS 1.2, which does not say,+-- is answered the same way: a record of two of them included.+checkChangeCipherSpec :: Fragment a -> Either TLSError ()+checkChangeCipherSpec fragment =+    case decodeChangeCipherSpec $ fragmentGetBytes fragment of+        Left _ ->+            Left $+                Error_Packet_unexpected "ChangeCipherSpec" " expected: the single byte 1"+        Right _ -> Right ()
Network/TLS/IO/Encode.hs view
@@ -2,7 +2,9 @@     encodePacket12,     encodePacket13,     updateTranscriptHash12,+    encodeUpdateTranscriptHash12,     updateTranscriptHash13,+    encodeUpdateTranscriptHash13, ) where  import Control.Concurrent.MVar@@ -47,8 +49,8 @@ -- packets are not fragmented here but by callers of sendPacket, so that the -- empty-packet countermeasure may be applied to each fragment independently. packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString]-packetToFragments12 ctx mlen (Handshake hss) =-    getChunks mlen . B.concat <$> mapM (updateTranscriptHash12 ctx) hss+packetToFragments12 ctx mlen (Handshake hss _) =+    getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x]@@ -73,17 +75,32 @@   where     isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) -updateTranscriptHash12 :: Context -> Handshake -> IO ByteString-updateTranscriptHash12 ctx hs = do+encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString+encodeUpdateTranscriptHash12 ctx hs = do     when (certVerifyHandshakeMaterial hs) $         usingHState ctx $             addHandshakeMessage encoded     let label = show $ typeOfHandshake hs     when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded+    when (isClientHello hs) $ do+        usingHState ctx $ do+            (ch, b) <- fromJust <$> getClientHello+            when (null b) $ setClientHello ch [encoded]     return encoded   where     encoded = encodeHandshake hs+    isClientHello (ClientHello _) = True+    isClientHello _ = False +updateTranscriptHash12 :: Context -> HandshakeR -> IO ()+updateTranscriptHash12 ctx (hs, bss) = do+    when (certVerifyHandshakeMaterial hs) $+        usingHState ctx $+            mapM_ addHandshakeMessage bss+    let label = show $ typeOfHandshake hs+    when (finishedHandshakeMaterial hs) $ do+        mapM_ (updateTranscriptHash ctx label) bss+ ----------------------------------------------------------------  encodePacket13@@ -100,14 +117,14 @@     fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx)  packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString]-packetToFragments13 ctx mlen (Handshake13 hss) =-    getChunks mlen . B.concat <$> mapM (updateTranscriptHash13 ctx) hss+packetToFragments13 ctx mlen (Handshake13 hss _) =+    getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments13 _ _ (AppData13 x) = return [x] packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] -updateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString-updateTranscriptHash13 ctx hs+encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString+encodeUpdateTranscriptHash13 ctx hs     | isIgnored hs = return encoded     | otherwise = do         let label = show $ typeOfHandshake13 hs@@ -117,6 +134,15 @@   where     encoded = encodeHandshake13 hs -    isIgnored NewSessionTicket13{} = True-    isIgnored KeyUpdate13{} = True-    isIgnored _ = False+updateTranscriptHash13 :: Context -> Handshake13R -> IO ()+updateTranscriptHash13 ctx (hs, bss)+    | isIgnored hs = return ()+    | otherwise = do+        let label = show $ typeOfHandshake13 hs+        mapM_ (updateTranscriptHash ctx label) bss+        usingHState ctx $ mapM_ addHandshakeMessage bss++isIgnored :: Handshake13 -> Bool+isIgnored NewSessionTicket13{} = True+isIgnored KeyUpdate13{} = True+isIgnored _ = False
Network/TLS/KeySchedule.hs view
@@ -8,7 +8,7 @@  import qualified Crypto.Hash as H import Crypto.KDF.HKDF-import Data.ByteArray (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS  import Network.TLS.Crypto@@ -20,7 +20,8 @@  -- | @HKDF-Extract@ function.  Returns the pseudorandom key (PRK) from salt and -- input keying material (IKM).-hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString+hkdfExtract+    :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba -> ba hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256) hkdfExtract SHA384 salt ikm = convert (extract salt ikm :: PRK H.SHA384)@@ -29,7 +30,7 @@  ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> TranscriptHash -> ByteString+deriveSecret :: Hash -> Secret -> ByteString -> TranscriptHash -> Secret deriveSecret h secret label (TranscriptHash hashedMsgs) =     hkdfExpandLabel h secret label hashedMsgs outlen   where@@ -40,12 +41,13 @@ -- | @HKDF-Expand-Label@ function.  Returns output keying material of the -- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel-    :: Hash-    -> ByteString+    :: (ByteArray ba, ByteArrayAccess ba)+    => Hash+    -> Secret     -> ByteString     -> ByteString     -> Int-    -> ByteString+    -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen   where     hkdfLabel = runPut $ do@@ -53,7 +55,8 @@         putOpaque8 ("tls13 " `BS.append` label)         putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString+expand'+    :: (ByteArray ba, ByteArrayAccess ba) => Hash -> Secret -> ByteString -> Int -> ba expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len expand' SHA256 secret label len = expand (extractSkip secret :: PRK H.SHA256) label len expand' SHA384 secret label len = expand (extractSkip secret :: PRK H.SHA384) label len
Network/TLS/MAC.hs view
@@ -6,24 +6,25 @@     prf_SHA256,     prf_TLS,     prf_MD5SHA1,+    PRF, ) where -import qualified Data.ByteArray as B (xor)-import qualified Data.ByteString as B+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as BA  import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString+type HMAC = Secret -> ByteString -> Secret  macSSL :: Hash -> HMAC macSSL alg secret msg =     f $-        B.concat+        BA.concat             [ secret-            , B.replicate padLen 0x5c-            , f $ B.concat [secret, B.replicate padLen 0x36, msg]+            , BA.replicate padLen 0x5c+            , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg]             ]   where     padLen = case alg of@@ -32,49 +33,51 @@         _ -> error ("internal error: macSSL called with " ++ show alg)     f = hash alg -hmac :: Hash -> HMAC-hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg)+hmac :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ByteString -> ba+hmac alg secret msg = f $ BA.append opad (f $ BA.append ipad $ BA.convert msg)   where-    opad = B.map (xor 0x5c) k'-    ipad = B.map (xor 0x36) k'+    opad = BA.map (0x5c `xor`) k'+    ipad = BA.map (0x36 `xor`) k'      f = hash alg     bl = hashBlockSize alg -    k' = B.append kt pad+    k' = BA.append kt pad       where-        kt = if B.length secret > fromIntegral bl then f secret else secret-        pad = B.replicate (fromIntegral bl - B.length kt) 0+        kt = if BA.length secret > fromIntegral bl then f secret else secret+        pad = BA.replicate (fromIntegral bl - BA.length kt) 0  hmacIter-    :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+    :: HMAC -> Secret -> ByteString -> ByteString -> Int -> [Secret] hmacIter f secret seed aprev len =     let an = f secret aprev-     in let out = f secret (B.concat [an, seed])-         in let digestsize = B.length out+     in let out = f secret (BA.concat [an, BA.convert seed])+         in let digestsize = BA.length out              in if digestsize >= len-                    then [B.take (fromIntegral len) out]-                    else out : hmacIter f secret seed an (len - digestsize)+                    then [BA.take (fromIntegral len) out]+                    else out : hmacIter f secret seed (BA.convert an) (len - digestsize) -prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len+type PRF = Secret -> ByteString -> Int -> Secret -prf_MD5 :: ByteString -> ByteString -> Int -> ByteString-prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len+prf_SHA1 :: PRF+prf_SHA1 secret seed len = BA.concat $ hmacIter (hmac SHA1) secret seed seed len -prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5 :: PRF+prf_MD5 secret seed len = BA.concat $ hmacIter (hmac MD5) secret seed seed len++prf_MD5SHA1 :: PRF prf_MD5SHA1 secret seed len =-    B.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+    BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)   where-    slen = B.length secret-    s1 = B.take (slen `div` 2 + slen `mod` 2) secret-    s2 = B.drop (slen `div` 2) secret+    slen = BA.length secret+    s1 = BA.take (slen `div` 2 + slen `mod` 2) secret+    s2 = BA.drop (slen `div` 2) secret -prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA256 secret seed len = B.concat $ hmacIter (hmac SHA256) secret seed seed len+prf_SHA256 :: PRF+prf_SHA256 secret seed len = BA.concat $ hmacIter (hmac SHA256) secret seed seed len  -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version.-prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString+prf_TLS :: Version -> Hash -> PRF prf_TLS _ halg secret seed len =-    B.concat $ hmacIter (hmac halg) secret seed seed len+    BA.concat $ hmacIter (hmac halg) secret seed seed len
Network/TLS/Packet.hs view
@@ -61,8 +61,7 @@     getPRF, ) where -import Data.ByteArray (ByteArrayAccess)-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArrayAccess, convert) import qualified Data.ByteString as B import Data.X509 (     CertificateChain,@@ -77,6 +76,7 @@ import Network.TLS.Struct import Network.TLS.Types import Network.TLS.Util.ASN1+import Network.TLS.Util.Serialization (os2ip) import Network.TLS.Wire  ----------------------------------------------------------------@@ -158,12 +158,33 @@ decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do     ty <- getHandshakeType-    content <- getOpaque24+    len <- getWord24+    -- Before the bytes, not after: the length is in the first four octets, so+    -- refusing here is refusing to hold anything.  Reassembly keeps every+    -- fragment until the message is whole, and the peer picks the number it+    -- announces.+    when (len > maxHandshakeSize) $+        fail $+            "handshake message of "+                ++ show len+                ++ " octets exceeds the limit of "+                ++ show maxHandshakeSize+    content <- getBytes len     return (ty, content)  {- FOURMOLU_DISABLE -} decodeHandshake     :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake+-- A ClientKeyExchange is only expected once a cipher, and with it a key+-- exchange, has been negotiated; one that comes without -- after Finished,+-- say -- is out of order rather than malformed.+decodeHandshake cp HandshakeType_ClientKeyXchg+    | isNothing (cParamsKeyXchgType cp) =+        const $+            Left $+                Error_Packet_unexpected+                    (show HandshakeType_ClientKeyXchg)+                    " expected: no ClientKeyExchange before a key exchange is negotiated" decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of     HandshakeType_HelloRequest     -> decodeHelloRequest     HandshakeType_ClientHello      -> decodeClientHello False@@ -338,8 +359,19 @@     parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic     parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic     parseCKE _ = fail "unsupported client key exchange type"-    parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16-    parseClientECDHPublic = CKX_ECDH <$> getOpaque8+    -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is+    -- malformed, a decode_error, before it is a public value that is not+    -- valid.+    parseClientDHPublic = do+        bs <- getOpaque16+        when (B.null bs) $ fail "empty DH public key"+        return $ CKX_DH $ dhPublic $ os2ip bs+    -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is+    -- malformed, a decode_error, before it is a point that does not decode.+    parseClientECDHPublic = do+        bs <- getOpaque8+        when (B.null bs) $ fail "empty ECDH public key"+        return $ CKX_ECDH bs  decodeFinished :: Get Handshake decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes)@@ -518,7 +550,7 @@             -- ECParameters ECCurveType: curve name type             grp <- Group <$> getWord16 -- ECParameters NamedCurve             mxy <- getOpaque8 -- ECPoint-            case decodeGroupPublic grp mxy of+            case groupDecodePublicA grp mxy of                 Left e -> fail $ "getServerECDHParams: " ++ show e                 Right grppub -> return $ ServerECDHParams grp grppub         _ -> fail "getServerECDHParams: unknown type for ECDH Params"@@ -528,7 +560,7 @@ putServerECDHParams (ServerECDHParams (Group grp) grppub) = do     putWord8 3 -- ECParameters ECCurveType     putWord16 grp -- ECParameters NamedCurve-    putOpaque8 $ encodeGroupPublic grppub -- ECPoint+    putOpaque8 $ groupEncodePublicA grppub -- ECPoint  ------------------------------------------------------------ @@ -556,8 +588,6 @@ ------------------------------------------------------------ -- generate things for packet content -type PRF = ByteString -> ByteString -> Int -> ByteString- -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getPRF :: Version -> Cipher -> PRF@@ -567,25 +597,23 @@     | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph  generateMainSecret_TLS-    :: ByteArrayAccess preMain-    => PRF-    -> preMain+    :: PRF+    -> Secret     -> ClientRandom     -> ServerRandom-    -> ByteString+    -> Secret generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) =-    prf (B.convert preMainSecret) seed 48+    prf preMainSecret seed 48   where     seed = B.concat ["master secret", c, s]  generateMainSecret-    :: ByteArrayAccess preMain-    => Version+    :: Version     -> Cipher-    -> preMain+    -> Secret     -> ClientRandom     -> ServerRandom-    -> ByteString+    -> Secret generateMainSecret v c = generateMainSecret_TLS $ getPRF v c  generateExtendedMainSecret@@ -594,14 +622,14 @@     -> Cipher     -> preMain     -> ByteString-    -> ByteString+    -> Secret generateExtendedMainSecret v c preMainSecret sessionHash =-    getPRF v c (B.convert preMainSecret) seed 48+    getPRF v c (convert preMainSecret) seed 48   where     seed = B.append "extended master secret" sessionHash  generateKeyBlock_TLS-    :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString+    :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize =     prf mainSecret seed kbsize   where@@ -612,9 +640,9 @@     -> Cipher     -> ClientRandom     -> ServerRandom-    -> ByteString+    -> Secret     -> Int-    -> ByteString+    -> Secret generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c  ------------------------------------------------------------
Network/TLS/Packet13.hs view
@@ -116,7 +116,18 @@ decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do     ty <- getHandshakeType-    content <- getOpaque24+    len <- getWord24+    -- Before the bytes, not after: the length is in the first four octets, so+    -- refusing here is refusing to hold anything.  Reassembly keeps every+    -- fragment until the message is whole, and the peer picks the number it+    -- announces.+    when (len > maxHandshakeSize) $+        fail $+            "handshake message of "+                ++ show len+                ++ " octets exceeds the limit of "+                ++ show maxHandshakeSize+    content <- getBytes len     return (ty, content)  {- FOURMOLU_DISABLE -}@@ -209,25 +220,39 @@         1 -> return $ KeyUpdate13 UpdateRequested         x -> fail $ "Unknown request_update: " ++ show x +-- RFC 8879 Section 4: a certificate that cannot be decompressed, or whose+-- decompressed length is not the declared one, is answered with+-- bad_certificate, and an algorithm that was not offered with+-- illegal_parameter.  errorToAlert tells them apart by the messages below.+-- A message that is malformed as a whole -- an empty+-- compressed_certificate_message, which its <1..2^24-1> bound forbids, or+-- bytes beyond the declared length -- is a decode_error, and is found+-- before anything is decompressed. decodeCompressedCertificate13 :: Get Handshake13 decodeCompressedCertificate13 = do     algo <- getWord16-    when (algo /= 1) $ fail "comp algo is not supported" -- fixme+    when (algo /= 1) $ fail "unsupported certificate compression algorithm" -- fixme     len <- getWord24     bs <- getOpaque24+    left <- remaining+    when (left /= 0) $ fail "bytes after compressed certificate"     if bs == ""         then fail "empty compressed certificate"-        else case decompressIt bs of-            Left e -> fail (show e)+        else case decompressIt len bs of+            Left e -> fail $ "certificate cannot be decompressed: " ++ show e             Right bs' -> do-                when (B.length bs' /= len) $ fail "plain length is wrong"+                when (B.length bs' /= len) $+                    fail "certificate cannot be decompressed: wrong uncompressed_length"                 case runGetMaybe decodeCertificate13 bs' of                     Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess                     --                    _ -> fail "compressed certificate cannot be parsed"                     _ -> fail $ "invalid compressed certificate: len = " ++ show len -decompressIt :: ByteString -> Either DecompressError ByteString-decompressIt inp = unsafePerformIO $ E.handle handler $ do-    Right . BL.toStrict <$> E.evaluate (decompress (BL.fromStrict inp))+decompressIt :: Int -> ByteString -> Either DecompressError ByteString+decompressIt limit inp = unsafePerformIO $ E.handle handler $ do+    -- One extra byte distinguishes exact-length output from oversized output.+    let output = BL.take (fromIntegral limit + 1) $ decompress $ BL.fromStrict inp+    Right <$> E.evaluate (BL.toStrict output)   where-    handler e = return $ Left (e :: DecompressError)+    handler :: DecompressError -> IO (Either DecompressError ByteString)+    handler e = return $ Left e
Network/TLS/Parameters.hs view
@@ -65,7 +65,7 @@     --     -- Default: 'Nothing'     , debugPrintSeed :: Seed -> IO ()-    -- ^ Add a way to print the seed that was randomly generated. re-using the same seed+    -- ^ Add a way to print the seed that was randomly generated. reusing the same seed     -- will reproduce the same randomness with 'debugSeed'     --     -- Default: no printing@@ -153,6 +153,16 @@     -- specified for TLS 1.2 but only the first entry is used.     --     -- Default: '[]'+    , clientWantTicket :: Bool+    -- ^ Whether to solicit TLS 1.2 session tickets (or TLS 1.3+    -- resumption PSKs) from servers.  With a 'False' setting,+    -- stateless clients that never do resumption can avoid+    -- wasting server and client resources used to generate,+    -- transmit and process tickets that will never be used.+    --+    -- Default: 'True'+    --+    -- @since 2.4.1     , clientShared :: Shared     -- ^ See the default value of 'Shared'.     , clientHooks :: ClientHooks@@ -192,6 +202,7 @@         , clientUseServerNameIndication = True         , clientWantSessionResume = Nothing         , clientWantSessionResumeList = []+        , clientWantTicket = True         , clientShared = def         , clientHooks = def         , clientSupported = def@@ -274,7 +285,7 @@     -- the server side, the highest version that is less or equal than     -- the client version will be chosen.     ---    -- Versions should be listed in preference order, i.e. higher+    -- Versions should be listed in preferred order, i.e. higher     -- versions first.     --     -- Default: @[TLS13,TLS12]@@@ -373,10 +384,23 @@     -- secure, but might help in rare cases.     --     --   Default: 'True'+    , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+    -- ^ Client only.+    --+    -- @since 2.1.9     , supportedGroups :: [Group]     -- ^ A list of supported elliptic curves and finite-field groups-    --   in the preferred order.+    --   in preferred order.     --+    --   * TLS 1.3 client: this list is used as the 1st argument to+    --     'onSelectKeyShareGroups' to select groups in "key_share".+    --     This list is also used as values of "supported_groups".+    --   * TLS 1.3 server: this list is not used.+    --   * TLS 1.2 client: this list is also used as values of+    --     "supported_groups".+    --   * TLS 1.2 server: this list is used to select a key exchange+    --     mechanism.+    --     --   The list is sent to the server as part of the     --   "supported_groups" extension.  It is used in both clients and     --   servers to restrict accepted groups in DH key exchange.  Up@@ -386,11 +410,18 @@     --   The default value includes all groups with security strength     --   of 128 bits or more.     ---    --   Default: @[X25519,X448,P256,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@-    , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]-    -- ^ Client only.+    --   Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@+    , supportedGroupsTLS13 :: [[Group]]+    -- ^ The inside @[Group]@ is the list of @Group@ at the same level+    -- in preferred order.  The inside @[Group]@s are also listed in+    -- preferred order.     ---    -- @since 2.1.9+    -- TLS 1.3 server: this is used as the 1st argument to+    -- 'onSelectKeyShare'.+    --+    -- Default: @[[X25519MLKEM768,P256MLKEM768,P384MLKEM1024],[X25519,P256],[P384,X448,P521],[FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192],[MLKEM768,MLKEM1024]]@+    --+    -- @since 2.2.3     }     deriving (Show, Eq) @@ -427,8 +458,9 @@         , supportedSession = True         , supportedFallbackScsv = True         , supportedEmptyPacket = True-        , supportedGroups = supportedNamedGroups         , supportedHPKE = defaultHPKE+        , supportedGroups = supportedNamedGroups+        , supportedGroupsTLS13 = supportedNamedGroupsTLS13         }  instance Default Supported where@@ -608,10 +640,11 @@     -- "Data.X509.Validation".  This can be replaced with a custom     -- validation function using different settings.     ---    -- The function is not expected to verify the key-usage extension-    -- of the end-entity certificate, as this depends on the-    -- dynamically-selected cipher and this part should not be cached.-    -- Key-usage verification is performed by the library internally.+    -- The function is not expected to verify the key-usage or+    -- extended-key-usage extensions of the end-entity certificate.+    -- Key usage depends on the dynamically-selected cipher and this+    -- part should not be cached.  Both checks are performed by the+    -- library internally after this function accepts the chain.     --     -- Default: 'validateDefault'     , onSuggestALPN :: IO (Maybe [ByteString])@@ -637,11 +670,44 @@     --   (3) rejecting unless 1 < dh_p && pub < dh_p - 1     --   (4) rejecting if dh_size < 1024 (to prevent Logjam attack)     ---    --   See RFC 7919 section 3.1 for recommandations.+    --   See RFC 7919 section 3.1 for recommendations.     , onServerFinished :: Information -> IO ()     -- ^ When a handshake is done, this hook can check `Information`.+    , onSelectKeyShareGroups :: [Group] -> [Group]+    -- ^ A function to select groups in "key_share" by TLS 1.3 client.+    --+    --   Client's 'supportedGroups' is passed as the 1st argument.+    --+    --   The default function specifies a pair of hybrid (classical ++    --   post quantum) group and classical group to transit from+    --   classical key exchange to hybrid key exchange. With the+    --   default value of 'supportedGroups', X25519MLKEM and X25519+    --   are chosen.+    --+    --   Middleboxes may drop a ClientHello that contains large+    --   X2219MLKEM. In such environment, @take 1@, which selects+    --   X22519 only with the default value, is maybe a good+    --   candidate.+    --+    --   In the case where X22519 is only contained in "key_share", a+    --   wise-server without nasty middleboxes may ask the client to+    --   send X2219MLKEM via HelloRetryRequest as X2219MLKEM is+    --   specified in "supported_groups".+    --+    --   @since 2.2.3     } +defaultOnSelectKeyShareGroups :: [Group] -> [Group]+defaultOnSelectKeyShareGroups groups = take 1 hs ++ take 1 es+  where+    (hs, es) = partition isHybrid groups++isHybrid :: Group -> Bool+isHybrid X25519MLKEM768 = True+isHybrid P256MLKEM768 = True+isHybrid P384MLKEM1024 = True+isHybrid _ = False+ defaultClientHooks :: ClientHooks defaultClientHooks =     ClientHooks@@ -650,6 +716,7 @@         , onSuggestALPN = return Nothing         , onCustomFFDHEGroup = defaultGroupUsage 1024         , onServerFinished = \_ -> return ()+        , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups         }  instance Show ClientHooks where@@ -668,7 +735,7 @@     -- of the certificate.  This verification is performed by the     -- library internally.     ---    -- Default: returns the followings:+    -- Default: returns the following:     --     -- @     -- CertificateUsageReject (CertificateRejectOther "no client certificates expected")@@ -684,7 +751,7 @@     -- client version and the client list of ciphers.     --     -- This could be useful with old clients and as a workaround to-    -- the BEAST (where RC4 is sometimes prefered with TLS < 1.1)+    -- the BEAST (where RC4 is sometimes preferred with TLS < 1.1)     --     -- The client cipher list cannot be empty.     --@@ -719,6 +786,29 @@     --  of TLS 1.3.     --     -- Default: 'return'+    , onSelectKeyShare+        :: [[Group]]+        -> [Group]+        -> [Group]+        -> IO (Maybe Group, Bool)+    -- ^ A function to select one key share by TLS 1.3 server.+    --+    -- The 1st argument is server's 'supportedGroupsTLS13'.+    -- The 2nd arguments is client's groups in "supported_groups"+    -- The 3rd arguments is client's groups in "key_share".+    --+    -- 'True' in the result indicates sending a hello retry request+    -- with this group.+    --+    -- The default function targets @[Group]@ in the first argument in+    -- order.  If there is a common group among the "key_share"+    -- groups, it will use that group for key exchange.+    -- Alternatively, if there is a common group among the+    -- "supported_groups" groups, it will instruct to send the+    -- HelloRetryRequest using that group.  Otherwise, it will check+    -- the next @[Group]@.+    --+    -- @since 2.2.3     }  -- | Default value for 'ServerHooks'@@ -737,6 +827,7 @@         , onNewHandshake = \_ -> return True         , onALPNClientSuggest = Nothing         , onEncryptedExtensionsCreating = return+        , onSelectKeyShare = defaultOnSelectKeyShare         }  instance Show ServerHooks where@@ -744,6 +835,20 @@ instance Default ServerHooks where     def = defaultServerHooks +defaultOnSelectKeyShare+    :: [[Group]] -- Server groups+    -> [Group] -- Client's groups in "supported_groups"+    -> [Group] -- Client's groups in "key_share"+    -> IO (Maybe Group, Bool)+defaultOnSelectKeyShare serverSupportedLoL clientSupportedGroups clientKeyShareGroups = go serverSupportedLoL+  where+    go [] = return (Nothing, False)+    go (gs : gss) = case gs `intersect` clientKeyShareGroups of+        [] -> case gs `intersect` clientSupportedGroups of+            [] -> go gss+            h : _ -> return (Just h, True)+        g : _ -> return (Just g, False)+ -- | Information related to a running context, e.g. current cipher data Information = Information     { infoVersion :: Version@@ -783,6 +888,14 @@     -- certificate.     --     -- Default: 32+    , limitKeyUpdate :: Maybe Int+    -- ^ Maximum number of consecutive TLS 1.3 KeyUpdate messages accepted+    -- without intervening non-empty application data.  This bounds the CPU+    -- work and response amplification a peer can trigger while application+    -- code is blocked inside 'recvData'.  'Nothing' and non-positive values+    -- disable the limit; they do not disable KeyUpdate processing.+    --+    -- Default: @Just 32@     }     deriving (Eq, Show) @@ -792,4 +905,5 @@     Limit         { limitRecordSize = Nothing         , limitHandshakeFragment = 32+        , limitKeyUpdate = Just 32         }
Network/TLS/PostHandshake.hs view
@@ -26,8 +26,8 @@ -- | Handle a post-handshake authentication flight with TLS 1.3.  This -- is called automatically by 'recvData', in a context where the read -- lock is already taken. Client only.-postHandshakeAuthWith :: Context -> Handshake13 -> IO ()-postHandshakeAuthWith ctx hs =+postHandshakeAuthWith :: Context -> Handshake13R -> IO ()+postHandshakeAuthWith ctx hb =     withWriteLock ctx $         handleException ctx $-            doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs+            doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hb
Network/TLS/QUIC.hs view
@@ -116,7 +116,7 @@     { quicSend :: [(CryptLevel, ByteString)] -> IO ()     -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The     -- content transiting on this API is the plaintext of the fragments and-    -- QUIC responsability is to encrypt this payload with the key material+    -- QUIC responsibility is to encrypt this payload with the key material     -- given for the specified level and an appropriate encryption scheme.     --     -- The size of the fragments may exceed QUIC datagram limits so QUIC may@@ -194,7 +194,7 @@         let qexts = filterQTP exts         when (null qexts) $ do             throwCore $-                Error_Protocol "QUIC transport parameters are mssing" MissingExtension+                Error_Protocol "QUIC transport parameters are missing" MissingExtension         quicNotifyExtensions callbacks ctx qexts         quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -222,7 +222,7 @@         let qexts = filterQTP exts         when (null qexts) $ do             throwCore $-                Error_Protocol "QUIC transport parameters are mssing" MissingExtension+                Error_Protocol "QUIC transport parameters are missing" MissingExtension         quicNotifyExtensions callbacks ctx qexts         quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo)         quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)
Network/TLS/Record/Decrypt.hs view
@@ -6,7 +6,8 @@  import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -58,25 +59,40 @@     nonEmptyContentTypes = [ProtocolType_Handshake, ProtocolType_Alert]     unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c -getCipherData :: Record a -> CipherData -> RecordM ByteString-getCipherData (Record pt ver _) cdata = do+-- | Check a decrypted record.+--+-- The first 'Bool' is what the lengths already said: 'False' when the padding+-- length the record claims cannot be one.  It is carried in rather than+-- answered where it was found, so that the MAC is computed either way -- see+-- 'decryptData'.+--+-- Everything is computed before anything is decided, and the verdicts are+-- combined with '&&!', which does not short-circuit.+getCipherData :: Record a -> Bool -> CipherData -> RecordM ByteString+getCipherData (Record pt ver _) lengthValid cdata = do     -- check if the MAC is valid.     macValid <- case cipherDataMAC cdata of         Nothing -> return True         Just digest -> do             let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata)             expected_digest <- makeDigest new_hdr $ cipherDataContent cdata-            return (expected_digest == digest)+            -- constEq rather than (==): (==) on ByteString is memcmp, which+            -- returns as soon as two octets differ, and how soon is a+            -- measurement of how much of the MAC was guessed correctly.+            return (expected_digest `BA.constEq` digest)      -- check if the padding is filled with the correct pattern if it exists     -- (before TLS10 this checks instead that the padding length is minimal)     paddingValid <- case cipherDataPadding cdata of         Nothing -> return True         Just (pad, _blksz) -> do-            let b = B.length pad - 1-            return $ B.replicate (B.length pad) (fromIntegral b) == pad+            let b = fromIntegral (B.length pad - 1)+            -- Every octet, and no allocation of a pattern to compare against:+            -- B.all stops at the first wrong octet, and replicating the+            -- pattern costs time in proportion to a length the peer chose.+            return $ B.foldl' (\acc w -> acc .|. (w `xor` b)) 0 pad == 0 -    unless (macValid &&! paddingValid) $+    unless (lengthValid &&! macValid &&! paddingValid) $         throwError $             Error_Protocol "bad record mac Stream/Block" BadRecordMac @@ -114,9 +130,13 @@     blockSize = bulkBlockSize bulk     econtentLen = B.length econtent +    -- A record too short for the cipher cannot be deprotected: RFC 5246+    -- Section 7.2.2 and RFC 8446 Section 5.2 answer it with bad_record_mac.     sanityCheckError =-        throwError-            (Error_Packet "encrypted content too small for encryption parameters")+        throwError $+            Error_Protocol+                "encrypted content too small for encryption parameters"+                BadRecordMac      decryptOf :: BulkState -> RecordM ByteString     decryptOf (BulkStateBlock decryptF) = do@@ -133,11 +153,25 @@         let (content', iv') = decryptF iv econtent'         modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}} -        let paddinglength = fromIntegral (B.last content') + 1-        let contentlen = B.length content' - paddinglength - macSize+        -- The last octet of the plaintext says how much padding there is.+        -- It may say more than the record can hold, and that already settles+        -- the record -- but answering it here, by splitting the record and+        -- failing, would answer it *without computing the MAC*.  How long a+        -- record takes to reject would then say whether the padding length+        -- was plausible, which is the question the attacker is asking.+        --+        -- So carry the verdict instead and go on with a length that fits.+        -- getCipherData folds it in with the MAC, and the answer is the same+        -- BadRecordMac either way.+        let plainlen = B.length content'+            claimed = fromIntegral (B.last content') + 1+            lengthValid = claimed + macSize <= plainlen+            paddinglength = if lengthValid then claimed else 1+            contentlen = plainlen - paddinglength - macSize         (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength)         getCipherData             record+            lengthValid             CipherData                 { cipherDataContent = content                 , cipherDataMAC = Just mac@@ -154,6 +188,7 @@         modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}}         getCipherData             record+            True             CipherData                 { cipherDataContent = content                 , cipherDataMAC = Just mac@@ -180,11 +215,11 @@                 | otherwise = B.concat [encodedSeq, encodeHeader hdr]             sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq             nonce-                | nonceExpLen == 0 = B.xor iv sqnc+                | nonceExpLen == 0 = BA.xor iv sqnc                 | otherwise = iv `B.append` enonce             (content, authTag2) = decryptF nonce econtent' ad -        when (AuthTag (B.convert authTag) /= authTag2) $+        when (AuthTag (convert authTag) /= authTag2) $             throwError $                 Error_Protocol "bad record mac on AEAD" BadRecordMac @@ -193,9 +228,11 @@     decryptOf BulkStateUninitialized =         throwError $ Error_Protocol "decrypt state uninitialized" InternalError -    -- handling of outer format can report errors with Error_Packet+    -- the outer format of a record that cannot be deprotected is reported+    -- as an integrity failure too, i.e. BadRecordMac     get3o s ls =-        maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls+        maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $+            partition3 s ls     get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2)      -- all format errors related to decrypted content are reported
Network/TLS/Record/Encrypt.hs view
@@ -13,7 +13,8 @@  import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -117,12 +118,12 @@             | otherwise = B.concat [encodedSeq, encodeHeader hdr]         sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq         nonce-            | nonceExpLen == 0 = B.xor iv sqnc+            | nonceExpLen == 0 = BA.xor iv sqnc             | otherwise = B.concat [iv, encodedSeq]         (e, AuthTag authtag) = encryptF nonce content ad         econtent-            | nonceExpLen == 0 = e `B.append` B.convert authtag-            | otherwise = B.concat [encodedSeq, e, B.convert authtag]+            | nonceExpLen == 0 = e `B.append` convert authtag+            | otherwise = B.concat [encodedSeq, e, convert authtag]     modify' incrRecordState     return econtent
Network/TLS/Record/Recv.hs view
@@ -50,7 +50,8 @@     -- ^ TLS context     -> IO (Either TLSError (Record Plaintext)) recvRecord12 ctx =-    readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+    readExactBytes ctx 5+        >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType))   where     recvLengthE = either (return . Left) recvLength @@ -69,7 +70,9 @@                     >>= either (return . Left) (getRecord ctx header)  recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))-recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+recvRecord13 ctx =+    readExactBytes ctx 5+        >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType))   where     recvLengthE = either (return . Left) recvLength     recvLength header@(Header _ _ readlen) = do@@ -90,6 +93,24 @@  maximumSizeExceeded :: TLSError maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow++-- RFC 8446 Section 5: a record of an unexpected type is answered with+-- unexpected_message.  Checked on the header, before the body is read, so+-- that what is no TLS record at all -- an SSLv2 ClientHello, say, whose first+-- byte reads as type 0x80 and whose length can ask for bytes that never+-- come -- is answered at once rather than when the peer gives up.+checkType :: Header -> Either TLSError Header+checkType header@(Header ty _ _)+    | ty `elem` known = Right header+    | otherwise =+        Left $ Error_Packet_unexpected (show ty) " expected: TLS record type"+  where+    known =+        [ ProtocolType_ChangeCipherSpec+        , ProtocolType_Alert+        , ProtocolType_Handshake+        , ProtocolType_AppData+        ]  ----------------------------------------------------------------
Network/TLS/Record/State.hs view
@@ -22,6 +22,7 @@ ) where  import Control.Monad.State.Strict+import qualified Data.ByteArray as BA import qualified Data.ByteString as B  import Network.TLS.Cipher@@ -36,10 +37,10 @@  data CryptState = CryptState     { cstKey :: BulkState-    , cstIV :: ByteString+    , cstIV :: IV     , -- In TLS 1.2 or earlier, this holds mac secret.       -- In TLS 1.3, this holds application traffic secret N.-      cstMacSecret :: ByteString+      cstMacSecret :: Secret     }     deriving (Show) @@ -130,7 +131,7 @@         { stCipher = Nothing         , stCompression = nullCompression         , stCryptLevel = CryptInitial-        , stCryptState = CryptState BulkStateUninitialized B.empty B.empty+        , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty         , stMacState = MacState 0         } @@ -153,7 +154,7 @@     :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest _ver tstate hdr content = (digest, incrRecordState tstate)   where-    digest = macF (cstMacSecret cst) msg+    digest = BA.convert $ macF (cstMacSecret cst) msg     cst = stCryptState tstate     cipher = fromJust $ stCipher tstate     hashA = cipherHash cipher
Network/TLS/State.hs view
@@ -25,6 +25,7 @@     setVersion,     setVersionIfUnset,     getVersion,+    getVersionMaybe,     getVersionWithDefault,     setSecureRenegotiation,     getSecureRenegotiation,@@ -79,7 +80,7 @@ import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct-import Network.TLS.Types (HostName, Role (..), Ticket)+import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation)  data TLSState = TLSState@@ -93,8 +94,10 @@       stServerCertificateChain :: Maybe CertificateChain     , stExtensionALPN :: Bool -- RFC 7301     , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol-    , stHandshakeRecordCont12 :: Maybe (GetContinuation (HandshakeType, ByteString))-    , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString))+    , stHandshakeRecordCont12+        :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)+    , stHandshakeRecordCont13+        :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes)     , stClientALPNSuggest :: Maybe [ByteString]     , stClientGroupSuggest :: Maybe [Group]     , stClientEcPointFormatSuggest :: Maybe [EcPointFormat]@@ -111,7 +114,7 @@     , stTLS13PreSharedKey :: Maybe PreSharedKey     , stTLS13HRR :: Bool     , stTLS13Cookie :: Maybe Cookie-    , stTLS13ExporterSecret :: Maybe ByteString+    , stTLS13ExporterSecret :: Maybe Secret     , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication     } @@ -136,8 +139,8 @@         , stServerCertificateChain = Nothing         , stExtensionALPN = False         , stNegotiatedProtocol = Nothing-        , stHandshakeRecordCont12 = Nothing-        , stHandshakeRecordCont13 = Nothing+        , stHandshakeRecordCont12 = (Nothing, [])+        , stHandshakeRecordCont13 = (Nothing, [])         , stClientALPNSuggest = Nothing         , stClientGroupSuggest = Nothing         , stClientEcPointFormatSuggest = Nothing@@ -230,6 +233,14 @@     fromMaybe (error "internal error: version hasn't been set yet")         <$> gets stVersion +-- | The negotiated version, or 'Nothing' before there is one.+--+-- 'getVersion' calls 'error' in that case, which is the right answer inside+-- the handshake -- reaching it there would be a bug -- and the wrong one for+-- anything a user of the library can call before the handshake has run.+getVersionMaybe :: TLSSt (Maybe Version)+getVersionMaybe = gets stVersion+ getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion @@ -335,10 +346,10 @@ getTLS12SessionTicket :: TLSSt (Maybe Ticket) getTLS12SessionTicket = gets stTLS12SessionTicket -setTLS13ExporterSecret :: ByteString -> TLSSt ()+setTLS13ExporterSecret :: Secret -> TLSSt () setTLS13ExporterSecret key = modify' (\st -> st{stTLS13ExporterSecret = Just key}) -getTLS13ExporterSecret :: TLSSt (Maybe ByteString)+getTLS13ExporterSecret :: TLSSt (Maybe Secret) getTLS13ExporterSecret = gets stTLS13ExporterSecret  setTLS13KeyShare :: Maybe KeyShare -> TLSSt ()
Network/TLS/Struct.hs view
@@ -118,6 +118,7 @@     hrrRandom,     ClientHello (..),     ServerHello (..),+    HandshakeR, ) where  import Data.X509 (@@ -231,14 +232,14 @@ ----------------------------------------------------------------  data Packet-    = Handshake [Handshake]+    = Handshake [Handshake] [WireBytes]     | Alert [(AlertLevel, AlertDescription)]     | ChangeCipherSpec     | AppData ByteString     deriving (Eq)  instance Show Packet where-    show (Handshake hs) = "Handshake " ++ show hs+    show (Handshake hs _) = "Handshake " ++ show hs     show (Alert as) = "Alert " ++ show as     show ChangeCipherSpec = "ChangeCipherSpec"     show (AppData bs) = "AppData " ++ showBytesHex bs@@ -362,7 +363,7 @@  ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic+data ServerECDHParams = ServerECDHParams Group GroupPublicA     deriving (Show, Eq)  ----------------------------------------------------------------@@ -478,7 +479,7 @@  {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType-packetType (Handshake _)    = ProtocolType_Handshake+packetType (Handshake _ _)  = ProtocolType_Handshake packetType (Alert _)        = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _)      = ProtocolType_AppData@@ -496,3 +497,5 @@ typeOfHandshake Finished{}         = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -}++type HandshakeR = (Handshake, WireBytes)
Network/TLS/Struct13.hs view
@@ -8,6 +8,7 @@     isKeyUpdate13,     TicketNonce (..),     SessionIDorTicket_ (..),+    Handshake13R, ) where  import Network.TLS.Imports@@ -15,7 +16,7 @@ import Network.TLS.Types  data Packet13-    = Handshake13 [Handshake13]+    = Handshake13 [Handshake13] [WireBytes]     | Alert13 [(AlertLevel, AlertDescription)]     | ChangeCipherSpec13     | AppData13 ByteString@@ -76,3 +77,5 @@ isKeyUpdate13 :: Handshake13 -> Bool isKeyUpdate13 (KeyUpdate13 _) = True isKeyUpdate13 _ = False++type Handshake13R = (Handshake13, WireBytes)
Network/TLS/Types.hs view
@@ -11,7 +11,9 @@     bigNumToInteger,     bigNumFromInteger,     defaultRecordSizeLimit,+    maxHandshakeSize,     TranscriptHash (..),+    WireBytes, ) where  import Network.Socket (HostName)@@ -60,7 +62,27 @@  ---------------------------------------------------------------- +-- | The largest handshake message we will reassemble.+--+-- A handshake message carries a 24-bit length, so a peer may announce close+-- to 16MB and then feed it a record at a time.  Records are bounded, but the+-- message they are reassembled into was not, and the fragments are held until+-- it is complete -- before anything has authenticated the peer.+--+-- The largest legitimate one is a Certificate message.  A long chain of+-- post-quantum certificates runs to tens of kilobytes, so this leaves an+-- order of magnitude over anything real while taking two orders of magnitude+-- off what a peer can ask us to hold.+maxHandshakeSize :: Int+maxHandshakeSize = 262144++----------------------------------------------------------------+ newtype TranscriptHash = TranscriptHash ByteString  instance Show TranscriptHash where     show (TranscriptHash bs) = showBytesHex bs++----------------------------------------------------------------++type WireBytes = [ByteString]
Network/TLS/Types/Cipher.hs view
@@ -4,6 +4,7 @@ module Network.TLS.Types.Cipher where  import Crypto.Cipher.Types (AuthTag)+import Data.ByteArray (ScrubbedBytes) import Data.IORef import GHC.Generics import System.IO.Unsafe (unsafePerformIO)@@ -15,6 +16,16 @@  ---------------------------------------------------------------- +type PlainText = ByteString+type CipherText = ByteString+type Secret = ScrubbedBytes+type Key = ScrubbedBytes+type IV = ByteString+type Nonce = ByteString -- aka IV+type AddDat = ByteString++----------------------------------------------------------------+ -- | Cipher identification type CipherID = Word16 @@ -106,12 +117,12 @@ data BulkDirection = BulkEncrypt | BulkDecrypt     deriving (Show, Eq) -type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV)--type BulkKey = ByteString-type BulkIV = ByteString-type BulkNonce = ByteString+type BulkKey = Secret+type BulkIV = Nonce+type BulkNonce = Nonce type BulkAdditionalData = ByteString++type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV)  newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream))
Network/TLS/Types/Secret.hs view
@@ -1,6 +1,17 @@+-- | The secret types of the TLS key schedule.+--+-- None of these prints its key material: 'Show' renders @\<secret\>@, since+-- these values reach a QUIC implementation through+-- "Network.TLS.QUIC" and are the kind of thing a handshake trace prints+-- without meaning to.  'Crypto.Debug.debugShow' returns the hexadecimal that+-- 'Show' used to, for a debugging session that wants it.  @SSLKEYLOGFILE@+-- does not go through either: it uses 'Network.TLS.Handshake.Key.LogLabel'. module Network.TLS.Types.Secret where +import Crypto.Debug (DebugShow (..))+import Data.ByteArray (convert) import Network.TLS.Imports+import Network.TLS.Types.Cipher  -- | Phantom type indicating early traffic secret. data EarlySecret@@ -13,30 +24,42 @@  data ResumptionSecret -newtype BaseSecret a = BaseSecret ByteString+newtype BaseSecret a = BaseSecret Secret  instance Show (BaseSecret a) where-    show (BaseSecret bs) = showBytesHex bs+    show _ = "<secret>" -newtype AnyTrafficSecret a = AnyTrafficSecret ByteString+instance DebugShow (BaseSecret a) where+    debugShow (BaseSecret bs) = showBytesHex $ convert bs +newtype AnyTrafficSecret a = AnyTrafficSecret Secret+ instance Show (AnyTrafficSecret a) where-    show (AnyTrafficSecret bs) = showBytesHex bs+    show _ = "<secret>" +instance DebugShow (AnyTrafficSecret a) where+    debugShow (AnyTrafficSecret bs) = showBytesHex $ convert bs+ -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ClientTrafficSecret a = ClientTrafficSecret ByteString+newtype ClientTrafficSecret a = ClientTrafficSecret Secret  instance Show (ClientTrafficSecret a) where-    show (ClientTrafficSecret bs) = showBytesHex bs+    show _ = "<secret>" +instance DebugShow (ClientTrafficSecret a) where+    debugShow (ClientTrafficSecret bs) = showBytesHex $ convert bs+ -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ServerTrafficSecret a = ServerTrafficSecret ByteString+newtype ServerTrafficSecret a = ServerTrafficSecret Secret  instance Show (ServerTrafficSecret a) where-    show (ServerTrafficSecret bs) = showBytesHex bs+    show _ = "<secret>" +instance DebugShow (ServerTrafficSecret a) where+    debugShow (ServerTrafficSecret bs) = showBytesHex $ convert bs+ data SecretTriple a = SecretTriple     { triBase :: BaseSecret a     , triClient :: ClientTrafficSecret a@@ -54,7 +77,10 @@ type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a)  -- Main secret for TLS 1.2 or earlier.-newtype MainSecret = MainSecret ByteString+newtype MainSecret = MainSecret Secret  instance Show MainSecret where-    show (MainSecret bs) = showBytesHex bs+    show _ = "<secret>"++instance DebugShow MainSecret where+    debugShow (MainSecret bs) = showBytesHex $ convert bs
Network/TLS/Types/Session.hs view
@@ -3,6 +3,7 @@ module Network.TLS.Types.Session where  import Codec.Serialise+import Crypto.Debug (DebugShow (..)) import qualified Data.ByteString as B import GHC.Generics import Network.Socket (HostName)@@ -38,14 +39,50 @@     , sessionCipher :: CipherID     , sessionCompression :: CompressionID     , sessionClientSNI :: Maybe HostName-    , sessionSecret :: ByteString+    , -- ScrubbedBytes is not an instance of Generic, sigh.+      sessionSecret :: ByteString     , sessionGroup :: Maybe Group     , sessionTicketInfo :: Maybe TLS13TicketInfo     , sessionALPN :: Maybe ByteString     , sessionMaxEarlyDataSize :: Int     , sessionFlags :: [SessionFlag]     } -- sessionFromTicket :: Bool-    deriving (Show, Eq, Generic)+    deriving (Eq, Generic)++-- | Everything but @sessionSecret@, which renders as @\<secret\>@: whoever+-- has it can resume the session.  'Crypto.Debug.debugShow' renders it.+instance Show SessionData where+    showsPrec = showsSessionData (showString "<secret>")++instance DebugShow SessionData where+    debugShow sd = showsSessionData (shows $ sessionSecret sd) 0 sd ""++-- | What the two instances above share, so that a field added to+-- 'SessionData' cannot reach one of them and not the other.+showsSessionData :: ShowS -> Int -> SessionData -> ShowS+showsSessionData secret d sd =+    showParen (d > 10) $+        showString "SessionData {sessionVersion = "+            . shows (sessionVersion sd)+            . showString ", sessionCipher = "+            . shows (sessionCipher sd)+            . showString ", sessionCompression = "+            . shows (sessionCompression sd)+            . showString ", sessionClientSNI = "+            . shows (sessionClientSNI sd)+            . showString ", sessionSecret = "+            . secret+            . showString ", sessionGroup = "+            . shows (sessionGroup sd)+            . showString ", sessionTicketInfo = "+            . shows (sessionTicketInfo sd)+            . showString ", sessionALPN = "+            . shows (sessionALPN sd)+            . showString ", sessionMaxEarlyDataSize = "+            . shows (sessionMaxEarlyDataSize sd)+            . showString ", sessionFlags = "+            . shows (sessionFlags sd)+            . showChar '}'  is0RTTPossible :: SessionData -> Bool is0RTTPossible sd = sessionMaxEarlyDataSize sd > 0
Network/TLS/Util.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Network.TLS.Util (     sub,@@ -17,8 +18,9 @@ ) where  import Control.Concurrent.MVar-import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B  import Network.TLS.Imports@@ -46,18 +48,24 @@     (p3, _) = B.splitAt d3 r2  partition6-    :: ByteString+    :: ScrubbedBytes     -> (Int, Int, Int, Int, Int, Int)-    -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString)-partition6 bytes (d1, d2, d3, d4, d5, d6) = if B.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6)+    -> Maybe+        ( ScrubbedBytes+        , ScrubbedBytes+        , ScrubbedBytes+        , ScrubbedBytes+        , ScrubbedBytes+        , ScrubbedBytes+        )+partition6 bytes (d1, d2, d3, d4, d5, d6) = if BA.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6)   where-    s = sum [d1, d2, d3, d4, d5, d6]-    (p1, r1) = B.splitAt d1 bytes-    (p2, r2) = B.splitAt d2 r1-    (p3, r3) = B.splitAt d3 r2-    (p4, r4) = B.splitAt d4 r3-    (p5, r5) = B.splitAt d5 r4-    (p6, _) = B.splitAt d6 r5+    slice' (beg, len) = BA.unsafeSlice bytes beg len+    lens = [d1, d2, d3, d4, d5, d6]+    s = sum lens+    begs = scanl (+) 0 lens+    ys = zip begs lens+    [p1, p2, p3, p4, p5, p6] = map slice' ys  -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool@@ -74,7 +82,7 @@   where     filterExn :: E.SomeException -> Maybe E.SomeException     filterExn e = case E.fromException (E.toException e) of-        Just (SomeAsyncException _) -> Nothing+        Just (E.SomeAsyncException _) -> Nothing         Nothing -> Just e  forEitherM :: Monad m => [a] -> (a -> m (Either l b)) -> m (Either l [b])
test/Arbitrary.hs view
@@ -380,8 +380,9 @@                         { supportedCiphers = serverCiphers                         , supportedVersions = serverVersions                         , supportedSecureRenegotiation = secNeg-                        , supportedGroups = serverGroups                         , supportedHashSignatures = serverHashSignatures+                        , supportedGroups = serverGroups+                        , supportedGroupsTLS13 = [serverGroups]                         }                 , serverShared = defaultShared{sharedCredentials = Credentials creds}                 }
test/Certificate.hs view
@@ -6,6 +6,7 @@     arbitraryX509,     arbitraryX509WithKey,     arbitraryX509WithKeyAndUsage,+    arbitraryRSACredentialWithPurpose,     arbitraryDN,     simpleCertificate,     simpleX509,@@ -117,6 +118,25 @@     let sigalg = getSignatureALG pubKey     let (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert     return signedExact++arbitraryRSACredentialWithPurpose+    :: ExtKeyUsagePurpose -> Gen (CertificateChain, PrivKey)+arbitraryRSACredentialWithPurpose purpose = do+    let (pubKey, privKey) = getGlobalRSAPair+    cert <- arbitraryCertificate knownKeyUsage $ PubKeyRSA pubKey+    sig <- resize 40 $ listOf1 arbitrary+    let cert' =+            cert+                { certExtensions =+                    Extensions $+                        Just+                            [ extensionEncode True $ ExtKeyUsage knownKeyUsage+                            , extensionEncode False $ ExtExtendedKeyUsage [purpose]+                            ]+                }+        sigalg = getSignatureALG $ PubKeyRSA pubKey+        (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert'+    return (CertificateChain [signedExact], PrivKeyRSA privKey)  arbitraryX509 :: Gen SignedCertificate arbitraryX509 = do
test/CiphersSpec.hs view
@@ -1,5 +1,6 @@ module CiphersSpec where +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -52,8 +53,8 @@     decrypted `shouldBe` t     at `shouldBe` at2 -arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk)+arbitraryKey :: Bulk -> Gen BA.ScrubbedBytes+arbitraryKey bulk = BA.pack `fmap` vector (bulkKeySize bulk)  arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk)@@ -61,7 +62,8 @@ arbitraryText :: Bulk -> Gen B.ByteString arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString+data BulkTest+    = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString     deriving (Show, Eq)  instance Arbitrary BulkTest where
test/ECHSpec.hs view
@@ -56,6 +56,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params =             setParams@@ -75,6 +76,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params =             setParams@@ -94,6 +96,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params0 =             setParams@@ -126,6 +129,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params0 =             setParams@@ -162,6 +166,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params0 =             setParams@@ -187,6 +192,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_CCM_SHA256]                 , supportedGroups = [P256]+                , supportedGroupsTLS13 = [[P256]]                 }      runTLSSimple13ECH (cli2, srv2') HelloRetryRequest@@ -202,6 +208,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         cliHooks =             defaultClientHooks@@ -256,6 +263,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [group0]+                , supportedGroupsTLS13 = [[group0]]                 }         params =             setParams@@ -286,6 +294,7 @@                     defaultSupported                         { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                         , supportedGroups = [group1]+                        , supportedGroupsTLS13 = [[group1]]                         }                 params1 =                     ( pc{clientUseEarlyData = True}@@ -319,7 +328,11 @@     EC cgrps <- generate arbitrary     EC sgrps <- generate arbitrary     let cliSupported = (clientSupported cli){supportedGroups = cgrps}-        svrSupported = (serverSupported srv){supportedGroups = sgrps}+        svrSupported =+            (serverSupported srv)+                { supportedGroups = sgrps+                , supportedGroupsTLS13 = [sgrps]+                }         params =             setParams                 ( cli{clientSupported = cliSupported}@@ -332,7 +345,12 @@     FFDHE cgrps <- generate arbitrary     FFDHE sgrps <- generate arbitrary     let cliSupported = (clientSupported cli){supportedGroups = cgrps}-        svrSupported = (serverSupported srv){supportedGroups = sgrps}+        svrSupported =+            (serverSupported srv)+                { supportedGroups = sgrps+                , supportedGroupsTLS13 = [sgrps]+                }+         params =             setParams                 ( cli{clientSupported = cliSupported}@@ -351,6 +369,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params =             ( cli@@ -379,6 +398,7 @@             defaultSupported                 { supportedCiphers = [cipher13_AES_128_GCM_SHA256]                 , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]                 }         params =             ( cli
test/EncodeSpec.hs view
@@ -1,8 +1,18 @@ module EncodeSpec where +import Codec.Compression.Zlib (compress)+import Control.Exception (bracket_, evaluate)+import Control.Monad (forM_, void) import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Either (isLeft)+import Data.Int (Int64)+import Data.Word (Word16)+import GHC.Conc (disableAllocationLimit, enableAllocationLimit, setAllocationCounter) import Network.TLS import Network.TLS.Internal+import Network.TLS.QUIC (errorToAlertDescription) import Test.Hspec import Test.Hspec.QuickCheck @@ -10,6 +20,36 @@  spec :: Spec spec = do+    describe "extension decoding" $ do+        prop "yields Nothing rather than throwing, for any message type" $+            \ws -> forM_ extensionDecoders $ \(name, decode) ->+                forM_ [minBound .. maxBound] $ \mt ->+                    decode mt (B.pack ws) `shouldReturn` name+    describe "handshake record length" $ do+        -- A handshake message carries a 24-bit length, and the fragments are+        -- held until the message is whole.  Refusing at the header means+        -- refusing to hold anything: the length arrives in the first four+        -- octets, before any of the body.+        it "refuses a length past the limit, on its header alone" $ do+            let tooBig = maxHandshakeSize + 1+            isGotError (decodeHandshakeRecord (handshakeHeader tooBig)) `shouldBe` True+            isGotError (decodeHandshakeRecord13 (handshakeHeader tooBig)) `shouldBe` True+        it "refuses the largest a 24-bit length can say" $ do+            let header = handshakeHeader 0xffffff+            isGotError (decodeHandshakeRecord header) `shouldBe` True+            isGotError (decodeHandshakeRecord13 header) `shouldBe` True+        -- Still waiting for the body rather than refusing it: at the limit+        -- the header alone is not enough to decide anything is wrong.+        it "asks for more at the limit itself" $ do+            let header = handshakeHeader maxHandshakeSize+            isGotPartial (decodeHandshakeRecord header) `shouldBe` True+            isGotPartial (decodeHandshakeRecord13 header) `shouldBe` True+        it "still decodes a message of an ordinary size" $ do+            let body = B.replicate 1000 0+                record = handshakeHeader (B.length body) `B.append` body+            gotThisMuch (B.length body) (decodeHandshakeRecord record) `shouldBe` True+            gotThisMuch (B.length body) (decodeHandshakeRecord13 record) `shouldBe` True+     describe "encoder/decoder" $ do         prop "can encode/decode Header" $ \x -> do             decodeHeader (encodeHeader x) `shouldBe` Right x@@ -17,7 +57,151 @@             decodeHs (encodeHandshake x) `shouldBe` Right x         prop "can encode/decode Handshake13" $ \x -> do             decodeHs13 (encodeHandshake13 x) `shouldBe` Right x+        it "round trips a valid TLS 1.3 compressed certificate" $ do+            let certificate =+                    CompressedCertificate13+                        B.empty+                        (CertificateChain_ $ CertificateChain [])+                        []+            decodeHs13 (encodeHandshake13 certificate) `shouldBe` Right certificate+        it "rejects decompressed output shorter than its declared size" $ do+            let plain = encodeCertificate13 B.empty (CertificateChain []) []+                compressed = BL.toStrict $ compress $ BL.fromStrict plain+                encoded = runPut $ do+                    putWord16 1+                    putWord24 (B.length plain + 1)+                    putOpaque24 compressed+            decodeHandshake13 HandshakeType_CompressedCertificate encoded+                `shouldSatisfy` isLeft+        -- RFC 8879 Section 4: a CompressedCertificate that cannot be+        -- decompressed, or whose decompressed length is not the one+        -- declared, is answered with bad_certificate; one with an algorithm+        -- that was not offered breaks no decoding rule but a field value,+        -- and is answered with illegal_parameter.  One malformed as a whole+        -- stays a decode_error.+        it "answers a decompressed length mismatch with bad_certificate" $ do+            let plain = encodeCertificate13 B.empty (CertificateChain []) []+                compressed = BL.toStrict $ compress $ BL.fromStrict plain+            compressedCertificateAlert 1 (B.length plain + 1) compressed+                `shouldBe` Just BadCertificate+        it "answers data that is not zlib with bad_certificate" $+            compressedCertificateAlert 1 16 (B.replicate 16 0xff)+                `shouldBe` Just BadCertificate+        it "answers an empty compressed certificate with decode_error" $+            compressedCertificateAlert 1 16 B.empty+                `shouldBe` Just DecodeError+        it "answers bytes after a compressed certificate with decode_error" $ do+            let plain = encodeCertificate13 B.empty (CertificateChain []) []+                compressed = BL.toStrict $ compress $ BL.fromStrict plain+            either (Just . errorToAlertDescription) (const Nothing)+                ( decodeHandshake13 HandshakeType_CompressedCertificate $+                    runPut $ do+                        putWord16 1+                        putWord24 (B.length plain)+                        putOpaque24 (B.drop 2 compressed)+                        putBytes (B.take 2 compressed)+                )+                `shouldBe` Just DecodeError+        it "answers an unsupported compression algorithm with illegal_parameter" $ do+            let plain = encodeCertificate13 B.empty (CertificateChain []) []+                compressed = BL.toStrict $ compress $ BL.fromStrict plain+            compressedCertificateAlert 2 (B.length plain) compressed+                `shouldBe` Just IllegalParameter+        -- A ClientKeyExchange is only expected once a cipher, and with it a+        -- key exchange, has been negotiated -- not, say, after Finished.+        -- One that comes without is out of order: unexpected_message.+        it "answers a ClientKeyExchange before a key exchange with unexpected_message" $+            either (Just . errorToAlertDescription) (const Nothing)+                ( decodeHandshake+                    CurrentParams{cParamsVersion = TLS12, cParamsKeyXchgType = Nothing}+                    HandshakeType_ClientKeyXchg+                    (B.replicate 130 1)+                )+                `shouldBe` Just UnexpectedMessage+        -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of+        -- ProtocolName<1..2^8-1>.+        it "refuses a malformed application_layer_protocol_negotiation" $+            forM_+                [ B.empty -- empty extension+                , B.pack [0, 0] -- empty list+                , B.pack [0, 1, 0] -- empty ProtocolName+                , B.pack [0, 2, 1, 104, 2, 104, 50] -- trailing data+                ]+                $ \bs ->+                    ( extensionDecode MsgTClientHello bs+                        :: Maybe ApplicationLayerProtocolNegotiation+                    )+                        `shouldBe` Nothing+        it "decodes an application_layer_protocol_negotiation" $+            ( extensionDecode MsgTClientHello (B.pack [0, 3, 2, 104, 50])+                :: Maybe ApplicationLayerProtocolNegotiation+            )+                `shouldBe` Just (ApplicationLayerProtocolNegotiation [B.pack [104, 50]])+        -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is+        -- malformed -- a decode_error -- rather than a point that does not+        -- decode, which is an illegal_parameter.+        it "answers an empty ECDH public key with decode_error" $+            either (Just . errorToAlertDescription) (const Nothing)+                ( decodeHandshake+                    CurrentParams+                        { cParamsVersion = TLS12+                        , cParamsKeyXchgType = Just CipherKeyExchange_ECDHE_RSA+                        }+                    HandshakeType_ClientKeyXchg+                    (B.singleton 0)+                )+                `shouldBe` Just DecodeError+        -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is+        -- malformed -- a decode_error -- rather than a public value that is+        -- not valid, which is an illegal_parameter.+        -- RFC 6066 Section 3: server_name_list<1..2^16-1> of+        -- HostName<1..2^16-1>.+        it "refuses a malformed server_name in ClientHello" $+            forM_+                [ B.empty -- empty extension+                , B.pack [0, 0] -- empty list+                , B.pack [0, 3, 0, 0, 0] -- empty host_name+                , B.pack [0, 4, 0, 0, 1, 101, 120] -- trailing data+                ]+                $ \bs ->+                    (extensionDecode MsgTClientHello bs :: Maybe ServerName)+                        `shouldBe` Nothing+        it "decodes a server_name in ClientHello" $+            (extensionDecode MsgTClientHello (B.pack [0, 4, 0, 0, 1, 101]) :: Maybe ServerName)+                `shouldBe` Just (ServerName [ServerNameHostName "e"])+        it "answers an empty DH public key with decode_error" $+            either (Just . errorToAlertDescription) (const Nothing)+                ( decodeHandshake+                    CurrentParams+                        { cParamsVersion = TLS12+                        , cParamsKeyXchgType = Just CipherKeyExchange_DHE_RSA+                        }+                    HandshakeType_ClientKeyXchg+                    (B.pack [0, 0])+                )+                `shouldBe` Just DecodeError+        it "bounds TLS 1.3 certificate decompression by the declared size" $ do+            let compressed = BL.toStrict $ compress $ BL.replicate (32 * 1024 * 1024) 0+                encoded = runPut $ do+                    putWord16 1+                    putWord24 1+                    putOpaque24 compressed+            _ <- evaluate $ B.length encoded+            decoded <-+                withinAllocationLimit (8 * 1024 * 1024) $+                    evaluate $+                        decodeHandshake13 HandshakeType_CompressedCertificate encoded+            decoded `shouldSatisfy` isLeft +compressedCertificateAlert :: Word16 -> Int -> ByteString -> Maybe AlertDescription+compressedCertificateAlert algo len compressed =+    either (Just . errorToAlertDescription) (const Nothing) $+        decodeHandshake13 HandshakeType_CompressedCertificate $+            runPut $ do+                putWord16 algo+                putWord24 len+                putOpaque24 compressed+ decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b   where@@ -30,6 +214,28 @@ decodeHs13 :: ByteString -> Either TLSError Handshake13 decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b +-- | A handshake record header: a type octet then a 24-bit length.+handshakeHeader :: Int -> ByteString+handshakeHeader len =+    B.pack+        [ 1 -- ClientHello+        , fromIntegral (len `div` 65536)+        , fromIntegral ((len `div` 256) `mod` 256)+        , fromIntegral (len `mod` 256)+        ]++isGotError :: GetResult a -> Bool+isGotError (GotError _) = True+isGotError _ = False++isGotPartial :: GetResult a -> Bool+isGotPartial (GotPartial _) = True+isGotPartial _ = False++gotThisMuch :: Int -> GetResult (a, ByteString) -> Bool+gotThisMuch n (GotSuccess (_, content)) = B.length content == n+gotThisMuch _ _ = False+ verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a verifyResult fn result =     case result of@@ -37,3 +243,48 @@         GotError e -> error ("got error: " ++ show e)         GotSuccessRemaining _ _ -> error "got remaining byte left"         GotSuccess (ty, content) -> fn ty content++withinAllocationLimit :: Int64 -> IO a -> IO a+withinAllocationLimit limit =+    bracket_+        (setAllocationCounter limit >> enableAllocationLimit)+        disableAllocationLimit++-- | Every 'Extension' instance, each wrapped so that the decoded value is+-- forced inside IO.  A partial 'extensionDecode' therefore surfaces as a+-- thrown exception the test can see, rather than as a thunk nobody looks at.+--+-- The name is threaded through as the return value only so that a failure+-- report says which instance it was.+type Decoder a = MessageType -> ByteString -> Maybe a++extensionDecoders :: [(String, MessageType -> ByteString -> IO String)]+extensionDecoders =+    [+      entry "ServerName" (extensionDecode :: Decoder ServerName),+      entry "MaxFragmentLength" (extensionDecode :: Decoder MaxFragmentLength),+      entry "SecureRenegotiation" (extensionDecode :: Decoder SecureRenegotiation),+      entry "ApplicationLayerProtocolNegotiation" (extensionDecode :: Decoder ApplicationLayerProtocolNegotiation),+      entry "ExtendedMainSecret" (extensionDecode :: Decoder ExtendedMainSecret),+      entry "CompressCertificate" (extensionDecode :: Decoder CompressCertificate),+      entry "SupportedGroups" (extensionDecode :: Decoder SupportedGroups),+      entry "EcPointFormatsSupported" (extensionDecode :: Decoder EcPointFormatsSupported),+      entry "RecordSizeLimit" (extensionDecode :: Decoder RecordSizeLimit),+      entry "SessionTicket" (extensionDecode :: Decoder SessionTicket),+      entry "HeartBeat" (extensionDecode :: Decoder HeartBeat),+      entry "SignatureAlgorithms" (extensionDecode :: Decoder SignatureAlgorithms),+      entry "SignatureAlgorithmsCert" (extensionDecode :: Decoder SignatureAlgorithmsCert),+      entry "SupportedVersions" (extensionDecode :: Decoder SupportedVersions),+      entry "KeyShare" (extensionDecode :: Decoder KeyShare),+      entry "PostHandshakeAuth" (extensionDecode :: Decoder PostHandshakeAuth),+      entry "PskKeyExchangeModes" (extensionDecode :: Decoder PskKeyExchangeModes),+      entry "PreSharedKey" (extensionDecode :: Decoder PreSharedKey),+      entry "EarlyDataIndication" (extensionDecode :: Decoder EarlyDataIndication),+      entry "Cookie" (extensionDecode :: Decoder Cookie),+      entry "CertificateAuthorities" (extensionDecode :: Decoder CertificateAuthorities),+      entry "EchOuterExtensions" (extensionDecode :: Decoder EchOuterExtensions),+      entry "EncryptedClientHello" (extensionDecode :: Decoder EncryptedClientHello)+    ]+  where+    entry name decode = (name, \mt bs -> name <$ evaluate (length (show (decode mt bs))))+
test/HandshakeSpec.hs view
@@ -2,1017 +2,2298 @@  module HandshakeSpec where -import Control.Monad-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.IORef-import Data.List-import Data.Maybe-import Data.X509 (ExtKeyUsageFlag (..))-import Network.TLS-import Network.TLS.Extra.Cipher-import Network.TLS.Internal-import Test.Hspec-import Test.Hspec.QuickCheck-import Test.QuickCheck--import API-import Arbitrary-import PipeChan-import Run-import Session--spec :: Spec-spec = do-    describe "pipe" $ do-        it "can setup a channel" pipe_work-    describe "handshake" $ do-        prop "can run TLS 1.2" handshake_simple-        prop "can run TLS 1.3" handshake13_simple-        prop "can update key for TLS 1.3" handshake_update_key-        prop "can prevent downgrade attack" handshake13_downgrade-        prop "can negotiate hash and signature" handshake_hashsignatures-        prop "can negotiate cipher suite" handshake_ciphersuites-        prop "can negotiate group" handshake_groups-        prop "can negotiate elliptic curve" handshake_ec-        prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher-        prop-            "can fallback for certificate with hash and signature"-            handshake_cert_fallback_hs-        prop "can handle server key usage" handshake_server_key_usage-        prop "can handle client key usage" handshake_client_key_usage-        prop "can authenticate client" handshake_client_auth-        prop "can receive client authentication failure" handshake_client_auth_fail-        prop "can handle extended main secret" handshake_ems-        prop "can resume with extended main secret" handshake_resumption_ems-        prop "can handle ALPN" handshake_alpn-        prop "can handle SNI" handshake_sni-        prop "can re-negotiate with TLS 1.2" handshake12_renegotiation-        prop "can resume session with TLS 1.2" handshake12_session_resumption-        prop "can resume session ticket with TLS 1.2" handshake12_session_ticket-        prop "can handshake with TLS 1.3 Full" handshake13_full-        prop "can handshake with TLS 1.3 HRR" handshake13_hrr-        prop "can handshake with TLS 1.3 PSK" handshake13_psk-        prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket-        prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback-        prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt-        prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback-        prop "can handshake with TLS 1.3 EE" handshake13_ee_groups-        prop "can handshake with TLS 1.3 EC groups" handshake13_ec-        prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe-        prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth------------------------------------------------------------------pipe_work :: IO ()-pipe_work = do-    pipe <- newPipe-    _ <- runPipe pipe--    let bSize = 16-    n <- generate (choose (1, 32))--    let d1 = B.replicate (bSize * n) 40-    let d2 = B.replicate (bSize * n) 45--    d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1)-    d1' `shouldBe` d1--    d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2)-    d2' `shouldBe` d2------------------------------------------------------------------handshake_simple :: (ClientParams, ServerParams) -> IO ()-handshake_simple = runTLSSimple------------------------------------------------------------------newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)--instance Arbitrary CSP13 where-    arbitrary = CSP13 <$> arbitraryPairParams13--handshake13_simple :: CSP13 -> IO ()-handshake13_simple (CSP13 params) = runTLSSimple13 params hs-  where-    cgrps = supportedGroups $ clientSupported $ fst params-    sgrps = supportedGroups $ serverSupported $ snd params-    hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest------------------------------------------------------------------handshake13_downgrade :: (ClientParams, ServerParams) -> IO ()-handshake13_downgrade (cparam, sparam) = do-    versionForced <--        generate $ elements (supportedVersions $ clientSupported cparam)-    let debug' = (serverDebug sparam){debugVersionForced = Just versionForced}-        sparam' = sparam{serverDebug = debug'}-        params = (cparam, sparam')-        downgraded =-            (isVersionEnabled TLS13 params && versionForced < TLS13)-                || (isVersionEnabled TLS12 params && versionForced < TLS12)-    if downgraded-        then runTLSFailure params handshake handshake-        else runTLSSimple params--handshake_update_key :: (ClientParams, ServerParams) -> IO ()-handshake_update_key = runTLSSimpleKeyUpdate------------------------------------------------------------------handshake_hashsignatures-    :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO ()-handshake_hashsignatures (clientHashSigs, serverHashSigs) = do-    tls13 <- generate arbitrary-    let version = if tls13 then TLS13 else TLS12-        ciphers =-            [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384-            , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384-            , cipher13_AES_128_GCM_SHA256-            ]-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                ([version], [version])-                (ciphers, ciphers)-    let clientParam' =-            clientParam-                { clientSupported =-                    (clientSupported clientParam)-                        { supportedHashSignatures = clientHashSigs-                        }-                }-        serverParam' =-            serverParam-                { serverSupported =-                    (serverSupported serverParam)-                        { supportedHashSignatures = serverHashSigs-                        }-                }-        commonHashSigs = clientHashSigs `intersect` serverHashSigs-        shouldFail-            | tls13 = all incompatibleWithDefaultCurve commonHashSigs-            | otherwise = null commonHashSigs-    if shouldFail-        then runTLSFailure (clientParam', serverParam') handshake handshake-        else runTLSSimple (clientParam', serverParam')-  where-    incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256-    incompatibleWithDefaultCurve _ = False--handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO ()-handshake_ciphersuites (clientCiphers, serverCiphers) = do-    tls13 <- generate arbitrary-    let version = if tls13 then TLS13 else TLS12-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                ([version], [version])-                (clientCiphers, serverCiphers)-    let adequate = cipherAllowedForVersion version-        shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers)-    if shouldSucceed-        then runTLSSimple (clientParam, serverParam)-        else runTLSFailure (clientParam, serverParam) handshake handshake------------------------------------------------------------------handshake_groups :: GGP -> IO ()-handshake_groups (GGP clientGroups serverGroups) = do-    tls13 <- generate arbitrary-    let versions = if tls13 then [TLS13] else [TLS12]-        ciphers = ciphersuite_strong-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                (versions, versions)-                (ciphers, ciphers)-    denyCustom <- generate arbitrary-    let groupUsage =-            if denyCustom-                then GroupUsageUnsupported "custom group denied"-                else GroupUsageValid-        clientParam' =-            clientParam-                { clientSupported =-                    (clientSupported clientParam)-                        { supportedGroups = clientGroups-                        }-                , clientHooks =-                    (clientHooks clientParam)-                        { onCustomFFDHEGroup = \_ _ -> return groupUsage-                        }-                }-        serverParam' =-            serverParam-                { serverSupported =-                    (serverSupported serverParam)-                        { supportedGroups = serverGroups-                        }-                }-        commonGroups = clientGroups `intersect` serverGroups-        shouldFail = null commonGroups-        p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups-    if shouldFail-        then runTLSFailure (clientParam', serverParam') handshake handshake-        else runTLSPredicate (clientParam', serverParam') p------------------------------------------------------------------newtype SG = SG [Group] deriving (Show)--instance Arbitrary SG where-    arbitrary = SG <$> shuffle sigGroups-      where-        sigGroups = [P256, P521]--handshake_ec :: SG -> IO ()-handshake_ec (SG sigGroups) = do-    let versions = [TLS12]-        ciphers =-            [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384-            ]-        hashSignatures =-            [ (HashSHA256, SignatureECDSA)-            ]-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                (versions, versions)-                (ciphers, ciphers)-    clientGroups <- generate $ shuffle sigGroups-    clientHashSignatures <- generate $ sublistOf hashSignatures-    serverHashSignatures <- generate $ sublistOf hashSignatures-    credentials <- generate arbitraryCredentialsOfEachCurve-    let clientParam' =-            clientParam-                { clientSupported =-                    (clientSupported clientParam)-                        { supportedGroups = clientGroups-                        , supportedHashSignatures = clientHashSignatures-                        }-                }-        serverParam' =-            serverParam-                { serverSupported =-                    (serverSupported serverParam)-                        { supportedGroups = sigGroups-                        , supportedHashSignatures = serverHashSignatures-                        }-                , serverShared =-                    (serverShared serverParam)-                        { sharedCredentials = Credentials credentials-                        }-                }-        sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)-        ecdsaDenied = SignatureECDSA `notElem` sigAlgs-    if ecdsaDenied-        then runTLSFailure (clientParam', serverParam') handshake handshake-        else runTLSSimple (clientParam', serverParam')---- Tests ability to use or ignore client "signature_algorithms" extension when--- choosing a server certificate.  Here peers allow DHE_RSA_AES128_SHA1 but--- the server RSA certificate has a SHA-1 signature that the client does not--- support.  Server may choose the DSA certificate only when cipher--- DHE_DSA_AES128_SHA1 is allowed.  Otherwise it must fallback to the RSA--- certificate.--data OC = OC [Cipher] [Cipher] deriving (Show)--instance Arbitrary OC where-    arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers-      where-        otherCiphers =-            [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384-            , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256-            ]--handshake_cert_fallback_cipher :: OC -> IO ()-handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do-    let clientVersions = [TLS12]-        serverVersions = [TLS12]-        commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256]-        hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)]-    chainRef <- newIORef Nothing-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                (clientVersions, serverVersions)-                (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers)-    let clientParam' =-            clientParam-                { clientSupported =-                    (clientSupported clientParam)-                        { supportedHashSignatures = hashSignatures-                        }-                , clientHooks =-                    (clientHooks clientParam)-                        { onServerCertificate = \_ _ _ chain ->-                            writeIORef chainRef (Just chain) >> return []-                        }-                }-    runTLSSimple (clientParam', serverParam)-    serverChain <- readIORef chainRef-    isLeafRSA serverChain `shouldBe` True---- Same as above but testing with supportedHashSignatures directly instead of--- ciphers, and thus allowing TLS13.  Peers accept RSA with SHA-256 but the--- server RSA certificate has a SHA-1 signature.  When Ed25519 is allowed by--- both client and server, the Ed25519 certificate is selected.  Otherwise the--- server fallbacks to RSA.------ Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13--- unless client advertises explicit support.  Currently this is not enforced by--- the library, which is useful to test this scenario.  SHA-1 could be replaced--- by another algorithm.--data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm]-    deriving (Show)--instance Arbitrary OHS where-    arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS-      where-        otherHS = [(HashIntrinsic, SignatureEd25519)]--handshake_cert_fallback_hs :: OHS -> IO ()-handshake_cert_fallback_hs (OHS clientHS serverHS) = do-    tls13 <- generate arbitrary-    let versions = if tls13 then [TLS13] else [TLS12]-        ciphers =-            [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256-            , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256-            , cipher13_AES_128_GCM_SHA256-            ]-        commonHS =-            [ (HashSHA256, SignatureRSA)-            , (HashIntrinsic, SignatureRSApssRSAeSHA256)-            ]-    chainRef <- newIORef Nothing-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                (versions, versions)-                (ciphers, ciphers)-    let clientParam' =-            clientParam-                { clientSupported =-                    (clientSupported clientParam)-                        { supportedHashSignatures = commonHS ++ clientHS-                        }-                , clientHooks =-                    (clientHooks clientParam)-                        { onServerCertificate = \_ _ _ chain ->-                            writeIORef chainRef (Just chain) >> return []-                        }-                }-        serverParam' =-            serverParam-                { serverSupported =-                    (serverSupported serverParam)-                        { supportedHashSignatures = commonHS ++ serverHS-                        }-                }-        eddsaDisallowed =-            (HashIntrinsic, SignatureEd25519) `notElem` clientHS-                || (HashIntrinsic, SignatureEd25519) `notElem` serverHS-    runTLSSimple (clientParam', serverParam')-    serverChain <- readIORef chainRef-    isLeafRSA serverChain `shouldBe` eddsaDisallowed------------------------------------------------------------------handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO ()-handshake_server_key_usage usageFlags = do-    tls13 <- generate arbitrary-    let versions = if tls13 then [TLS13] else [TLS12]-        ciphers = ciphersuite_all-    (clientParam, serverParam) <--        generate $-            arbitraryPairParamsWithVersionsAndCiphers-                (versions, versions)-                (ciphers, ciphers)-    cred <- generate $ arbitraryRSACredentialWithUsage usageFlags-    let serverParam' =-            serverParam-                { serverShared =-                    (serverShared serverParam)-                        { sharedCredentials = Credentials [cred]-                        }-                }-        shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags-    if shouldSucceed-        then runTLSSimple (clientParam, serverParam')-        else runTLSFailure (clientParam, serverParam') handshake handshake--handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO ()-handshake_client_key_usage usageFlags = do-    (clientParam, serverParam) <- generate arbitrary-    cred <- generate $ arbitraryRSACredentialWithUsage usageFlags-    let clientParam' =-            clientParam-                { clientHooks =-                    (clientHooks clientParam)-                        { onCertificateRequest = \_ -> return $ Just cred-                        }-                }-        serverParam' =-            serverParam-                { serverWantClientCert = True-                , serverHooks =-                    (serverHooks serverParam)-                        { onClientCertificate = \_ -> return CertificateUsageAccept-                        }-                }-        shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags-    if shouldSucceed-        then runTLSSimple (clientParam', serverParam')-        else runTLSFailure (clientParam', serverParam') handshake handshake------------------------------------------------------------------handshake_client_auth :: (ClientParams, ServerParams) -> IO ()-handshake_client_auth (clientParam, serverParam) = do-    let clientVersions = supportedVersions $ clientSupported clientParam-        serverVersions = supportedVersions $ serverSupported serverParam-        version = maximum (clientVersions `intersect` serverVersions)-    cred <- generate (arbitraryClientCredential version)-    let clientParam' =-            clientParam-                { clientHooks =-                    (clientHooks clientParam)-                        { onCertificateRequest = \_ -> return $ Just cred-                        }-                }-        serverParam' =-            serverParam-                { serverWantClientCert = True-                , serverHooks =-                    (serverHooks serverParam)-                        { onClientCertificate = validateChain cred-                        }-                }-    runTLSSimple (clientParam', serverParam')-  where-    validateChain cred chain-        | chain == fst cred = return CertificateUsageAccept-        | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)--handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO ()-handshake_client_auth_fail (clientParam, serverParam) = do-    let clientVersions = supportedVersions $ clientSupported clientParam-        serverVersions = supportedVersions $ serverSupported serverParam-        version = maximum (clientVersions `intersect` serverVersions)-    cred <- generate (arbitraryClientCredential version)-    let clientParam' =-            clientParam-                { clientHooks =-                    (clientHooks clientParam)-                        { onCertificateRequest = \_ -> return $ Just cred-                        }-                }-        serverParam' =-            serverParam-                { serverWantClientCert = True-                , serverHooks =-                    (serverHooks serverParam)-                        { onClientCertificate = validateChain cred-                        }-                }-    runTLSFailure (clientParam', serverParam') handshake handshake-  where-    validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA)------------------------------------------------------------------handshake_ems :: (EMSMode, EMSMode) -> IO ()-handshake_ems (cems, sems) = do-    params <- generate arbitrary-    let params' = setEMSMode (cems, sems) params-        version = getConnectVersion params'-        emsVersion = version >= TLS10 && version <= TLS12-        use = cems /= NoEMS && sems /= NoEMS-        require = cems == RequireEMS || sems == RequireEMS-        p info = infoExtendedMainSecret info == (emsVersion && use)-    if emsVersion && require && not use-        then runTLSFailure params' handshake handshake-        else runTLSPredicate params' (maybe False p)--newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show)--instance Arbitrary CompatEMS where-    arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible)-      where-        compatible (NoEMS, RequireEMS) = False-        compatible (RequireEMS, NoEMS) = False-        compatible _ = True--handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO ()-handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do-    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    plainParams <- generate arbitrary-    let params =-            setEMSMode ems $-                setPairParamsSessionManagers sessionManagers plainParams--    runTLSSimple params--    -- and resume-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let params2 =-            setEMSMode ems2 $-                setPairParamsSessionResuming (fromJust sessionParams) params--    let version = getConnectVersion params2-        emsVersion = version >= TLS10 && version <= TLS12--    if emsVersion && use ems && not (use ems2)-        then runTLSFailure params2 handshake handshake-        else do-            runTLSSimple params2-            mSessionParams2 <- readClientSessionRef sessionRefs-            let sameSession = sessionParams == mSessionParams2-                sameUse = use ems == use ems2-            when emsVersion (sameSession `shouldBe` sameUse)-  where-    use (NoEMS, _) = False-    use (_, NoEMS) = False-    use _ = True------------------------------------------------------------------handshake_alpn :: (ClientParams, ServerParams) -> IO ()-handshake_alpn (clientParam, serverParam) = do-    let clientParam' =-            clientParam-                { clientHooks =-                    (clientHooks clientParam)-                        { onSuggestALPN = return $ Just ["h2", "http/1.1"]-                        }-                }-        serverParam' =-            serverParam-                { serverHooks =-                    (serverHooks serverParam)-                        { onALPNClientSuggest = Just alpn-                        }-                }-        params' = (clientParam', serverParam')-    runTLSSuccess params' hsClient hsServer-  where-    hsClient ctx = do-        handshake ctx-        proto <- getNegotiatedProtocol ctx-        proto `shouldBe` Just "h2"-    hsServer ctx = do-        handshake ctx-        proto <- getNegotiatedProtocol ctx-        proto `shouldBe` Just "h2"-    alpn xs-        | "h2" `elem` xs = return "h2"-        | otherwise = return "http/1.1"--handshake_sni :: (ClientParams, ServerParams) -> IO ()-handshake_sni (clientParam, serverParam) = do-    ref <- newIORef Nothing-    let clientParam' =-            clientParam-                { clientServerIdentification = (serverName, "")-                }-        serverParam' =-            serverParam-                { serverHooks =-                    (serverHooks serverParam)-                        { onServerNameIndication = onSNI ref-                        }-                }-        params' = (clientParam', serverParam')-    runTLSSuccess params' hsClient hsServer-    receivedName <- readIORef ref-    receivedName `shouldBe` Just (Just serverName)-  where-    hsClient ctx = do-        handshake ctx-        msni <- getClientSNI ctx-        expectMaybe "C: SNI should be Just" serverName msni-    hsServer ctx = do-        handshake ctx-        msni <- getClientSNI ctx-        expectMaybe "S: SNI should be Just" serverName msni-    onSNI ref name = do-        mx <- readIORef ref-        mx `shouldBe` Nothing-        writeIORef ref (Just name)-        return (Credentials [])-    serverName = "haskell.org"------------------------------------------------------------------newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show)--instance Arbitrary CSP12 where-    arbitrary = CSP12 <$> arbitraryPairParams12--handshake12_renegotiation :: CSP12 -> IO ()-handshake12_renegotiation (CSP12 (cparams, sparams)) = do-    renegDisabled <- generate arbitrary-    let sparams' =-            sparams-                { serverSupported =-                    (serverSupported sparams)-                        { supportedClientInitiatedRenegotiation = not renegDisabled-                        }-                }-    if renegDisabled-        then runTLSFailure (cparams, sparams') hsClient hsServer-        else runTLSSimple (cparams, sparams')-  where-    hsClient ctx = handshake ctx >> handshake ctx-    -- recvData receives the alert from the second handshake-    hsServer ctx = handshake ctx >> void (recvData ctx)--handshake12_session_resumption :: CSP12 -> IO ()-handshake12_session_resumption (CSP12 plainParams) = do-    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    let params = setPairParamsSessionManagers sessionManagers plainParams--    runTLSSimple params--    -- and resume-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params--    runTLSPredicate params2 (maybe False infoTLS12Resumption)--handshake12_session_ticket :: CSP12 -> IO ()-handshake12_session_ticket (CSP12 plainParams) = do-    sessionRefs <- twoSessionRefs-    let sessionManagers0 = twoSessionManagers sessionRefs-        sessionManagers = (fst sessionManagers0, oneSessionTicket)--    let params = setPairParamsSessionManagers sessionManagers plainParams--    runTLSSimple params--    -- and resume-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params--    runTLSPredicate params2 (maybe False infoTLS12Resumption)------------------------------------------------------------------handshake13_full :: CSP13 -> IO ()-handshake13_full (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        params =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )-    runTLSSimple13 params FullHandshake--handshake13_hrr :: CSP13 -> IO ()-handshake13_hrr (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        params =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )-    runTLSSimple13 params HelloRetryRequest--handshake13_psk :: CSP13 -> IO ()-handshake13_psk (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        params0 =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )--    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    let params = setPairParamsSessionManagers sessionManagers params0--    runTLSSimple13 params HelloRetryRequest--    -- and resume-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params--    runTLSSimple13 params2 PreSharedKey--handshake13_psk_ticket :: CSP13 -> IO ()-handshake13_psk_ticket (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        params0 =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )--    sessionRefs <- twoSessionRefs-    let sessionManagers0 = twoSessionManagers sessionRefs-        sessionManagers = (fst sessionManagers0, oneSessionTicket)--    let params = setPairParamsSessionManagers sessionManagers params0--    runTLSSimple13 params HelloRetryRequest--    -- and resume-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params--    runTLSSimple13 params2 PreSharedKey--handshake13_psk_fallback :: CSP13 -> IO ()-handshake13_psk_fallback (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers =-                    [ cipher13_AES_128_GCM_SHA256-                    , cipher13_AES_128_CCM_SHA256-                    ]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        params0 =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )--    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    let params = setPairParamsSessionManagers sessionManagers params0--    runTLSSimple13 params HelloRetryRequest--    -- resumption fails because GCM cipher is not supported anymore, full-    -- handshake is not possible because X25519 has been removed, so we are-    -- back with P256 after hello retry-    sessionParams <- readClientSessionRef sessionRefs-    expectJust "session param should be Just" sessionParams-    let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params-        srv2' = srv2{serverSupported = svrSupported'}-        svrSupported' =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_CCM_SHA256]-                , supportedGroups = [P256]-                }--    runTLSSimple13 (cli2, srv2') HelloRetryRequest--handshake13_0rtt :: CSP13 -> IO ()-handshake13_0rtt (CSP13 (cli, srv)) = do-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [X25519]-                }-        cliHooks =-            defaultClientHooks-                { onSuggestALPN = return $ Just ["h2"]-                }-        svrHooks =-            defaultServerHooks-                { onALPNClientSuggest = Just (return . unsafeHead)-                }-        params0 =-            ( cli-                { clientSupported = cliSupported-                , clientHooks = cliHooks-                }-            , srv-                { serverSupported = svrSupported-                , serverHooks = svrHooks-                , serverEarlyDataSize = 2048-                }-            )--    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    let params = setPairParamsSessionManagers sessionManagers params0--    runTLSSimple13 params HelloRetryRequest-    runTLS0rtt params sessionRefs-    runTLS0rtt params sessionRefs-  where-    runTLS0rtt params sessionRefs = do-        -- and resume-        sessionParams <- readClientSessionRef sessionRefs-        expectJust "session param should be Just" sessionParams-        clearClientSessionRef sessionRefs-        earlyData <- B.pack <$> generate (someWords8 256)-        let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params-            params2 = (pc{clientUseEarlyData = True}, ps)--        runTLS0RTT params2 RTT0 earlyData--handshake13_0rtt_fallback :: CSP13 -> IO ()-handshake13_0rtt_fallback (CSP13 (cli, srv)) = do-    group0 <- generate $ elements [P256, X25519]-    let cliSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [P256, X25519]-                }-        svrSupported =-            defaultSupported-                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                , supportedGroups = [group0]-                }-        params =-            ( cli{clientSupported = cliSupported}-            , srv-                { serverSupported = svrSupported-                , serverEarlyDataSize = 1024-                }-            )--    sessionRefs <- twoSessionRefs-    let sessionManagers = twoSessionManagers sessionRefs--    let params0 = setPairParamsSessionManagers sessionManagers params--    let mode = if group0 == P256 then FullHandshake else HelloRetryRequest-    runTLSSimple13 params0 mode--    -- and resume-    mSessionParams <- readClientSessionRef sessionRefs-    case mSessionParams of-        Nothing -> expectationFailure "session params: Just is expected"-        Just sessionParams -> do-            earlyData <- B.pack <$> generate (someWords8 256)-            group1 <- generate $ elements [P256, X25519]-            let (pc, ps) = setPairParamsSessionResuming sessionParams params0-                svrSupported1 =-                    defaultSupported-                        { supportedCiphers = [cipher13_AES_128_GCM_SHA256]-                        , supportedGroups = [group1]-                        }-                params1 =-                    ( pc{clientUseEarlyData = True}-                    , ps-                        { serverEarlyDataSize = 0-                        , serverSupported = svrSupported1-                        }-                    )-            -- C: [P256, X25519]-            -- S: [group0]-            -- C: [P256, X25519]-            -- S: [group1]-            if group0 == group1-                -- 0-RTT is not allowed, so fallback to PreSharedKey-                then runTLS0RTT params1 PreSharedKey earlyData-                -- HRR but not allowed for 0-RTT-                else runTLSFailure params1 (tlsClient earlyData) tlsServer-  where-    tlsClient earlyData ctx = do-        handshake ctx-        sendData ctx $ L.fromStrict earlyData-        _ <- recvData ctx-        bye ctx-    tlsServer ctx = do-        handshake ctx-        _ <- recvData ctx-        bye ctx--handshake13_ee_groups :: CSP13 -> IO ()-handshake13_ee_groups (CSP13 (cli, srv)) = do-    let -- The client prefers P256-        cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]}-        -- The server prefers X25519-        svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]}-        params =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )-    (_, serverMessages) <- runTLSCapture13 params-    -- The server should tell X25519 in supported_groups in EE to clinet-    let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups-        eeMessagesHaveExt =-            [ any isSupportedGroups exts-            | EncryptedExtensions13 exts <- serverMessages-            ]-    eeMessagesHaveExt `shouldBe` [True]--handshake13_ec :: CSP13 -> IO ()-handshake13_ec (CSP13 (cli, srv)) = do-    EC cgrps <- generate arbitrary-    EC sgrps <- generate arbitrary-    let cliSupported = (clientSupported cli){supportedGroups = cgrps}-        svrSupported = (serverSupported srv){supportedGroups = sgrps}-        params =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )-    runTLSSimple13 params FullHandshake--handshake13_ffdhe :: CSP13 -> IO ()-handshake13_ffdhe (CSP13 (cli, srv)) = do-    FFDHE cgrps <- generate arbitrary-    FFDHE sgrps <- generate arbitrary-    let cliSupported = (clientSupported cli){supportedGroups = cgrps}-        svrSupported = (serverSupported srv){supportedGroups = sgrps}-        params =-            ( cli{clientSupported = cliSupported}-            , srv{serverSupported = svrSupported}-            )-    runTLSSimple13 params FullHandshake--post_handshake_auth :: CSP13 -> IO ()-post_handshake_auth (CSP13 (clientParam, serverParam)) = do-    cred <- generate (arbitraryClientCredential TLS13)-    let clientParam' =-            clientParam-                { clientHooks =-                    (clientHooks clientParam)-                        { onCertificateRequest = \_ -> return $ Just cred-                        }-                }-        serverParam' =-            serverParam-                { serverHooks =-                    (serverHooks serverParam)-                        { onClientCertificate = validateChain cred-                        }-                }-    if isCredentialDSA cred-        then runTLSFailure (clientParam', serverParam') hsClient hsServer-        else runTLSSuccess (clientParam', serverParam') hsClient hsServer-  where-    validateChain cred chain-        | chain == fst cred = return CertificateUsageAccept-        | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)-    hsClient ctx = do-        handshake ctx-        sendData ctx "request 1"-        recvDataAssert ctx "response 1"-        sendData ctx "request 2"-        recvDataAssert ctx "response 2"-    hsServer ctx = do-        handshake ctx-        recvDataAssert ctx "request 1"-        _ <- requestCertificate ctx -- single request-        sendData ctx "response 1"-        recvDataAssert ctx "request 2"-        _ <- requestCertificate ctx-        _ <- requestCertificate ctx -- two simultaneously-        sendData ctx "response 2"+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (concurrently_)+import qualified Control.Exception as E+import Control.Monad+import Crypto.Cipher.AES (AES128)+import Crypto.Cipher.Types (AEADMode (..), AuthTag (..), aeadInit, aeadSimpleEncrypt, cipherInit)+import Crypto.Error (throwCryptoError)+import Data.Bits (shiftR, xor)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Data.List+import Data.Maybe+import Data.Word (Word16, Word64, Word8)+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..))+import Network.TLS+import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC+import Network.TLS.Internal+import Network.TLS.QUIC (hkdfExpandLabel)+import Test.Hspec+import Test.Hspec.QuickCheck+import System.Timeout (timeout)+import Test.QuickCheck++import API+import Arbitrary+import Certificate (arbitraryRSACredentialWithPurpose)+import PipeChan+import Run+import Session++spec :: Spec+spec = do+    describe "pipe" $ do+        it "can setup a channel" pipe_work+    describe "channel binding" $ do+        prop "is unavailable before the handshake" binding_before_handshake+    describe "handshake" $ do+        prop "can run TLS 1.2" handshake_simple+        prop "can run TLS 1.3" handshake13_simple+        prop "can update key for TLS 1.3" handshake_update_key+        it+            "rejects more than 32 consecutive TLS 1.3 KeyUpdates"+            handshake_key_update_flood+        it+            "can disable the consecutive TLS 1.3 KeyUpdate limit"+            handshake_key_update_unlimited+        it+            "does not disable TLS 1.3 KeyUpdates with non-positive limits"+            handshake_key_update_non_positive+        prop "can prevent downgrade attack" handshake13_downgrade+        it "negotiates TLS 1.2 with a ClientHello naming a higher version" $+            handshake_high_legacy_version TLS12 (Version 0x0309)+        it "ignores legacy_version when supported_versions is present" $+            handshake_high_legacy_version TLS13 TLS13+        it "rejects ec_point_formats without uncompressed" $+            handshake12_ec_point_formats+                (B.pack [1, 1])+                rejectedAsIllegalParameter+        it "rejects an empty ec_point_formats" $+            handshake12_ec_point_formats (B.pack [0]) rejectedAsDecodeError+        prop "can negotiate hash and signature" handshake_hashsignatures+        prop "can negotiate cipher suite" handshake_ciphersuites+        it "rejects a cipher outside the server callback candidates" $+            handshake_rejects_server_cipher_callback_escape+        it "rejects a TLS 1.2-only cipher selected for TLS 1.3" $+            handshake_rejects_legacy_cipher_in_tls13+        prop "can negotiate group" handshake_groups+        prop "can negotiate elliptic curve" handshake_ec+        prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher+        prop+            "can fallback for certificate with hash and signature"+            handshake_cert_fallback_hs+        prop "can handle server key usage" handshake_server_key_usage+        it "accepts a TLS 1.2 server certificate permitting server auth" $+            handshake_server_key_purpose TLS12 KeyUsagePurpose_ServerAuth True+        it "accepts a TLS 1.3 server certificate permitting server auth" $+            handshake_server_key_purpose TLS13 KeyUsagePurpose_ServerAuth True+        it "rejects a TLS 1.2 server certificate restricted to client auth" $+            handshake_server_key_purpose TLS12 KeyUsagePurpose_ClientAuth False+        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+        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+        it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $+            handshake12_client_cert_verify_sigalg+                (HashSHA256, SignatureECDSA)+                rejectedAsIllegalParameter+        it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $+            handshake12_client_cert_verify_sigalg+                (HashIntrinsic, SignatureRSApsspssSHA256)+                rejectedAsDecryptError+        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+        it "accepts an empty TLS 1.3 client certificate when the hook does" $+            handshake_client_auth_empty TLS13+        it "requests only defined certificate types in TLS 1.2" $+            handshake12_cert_request_types+        prop "can handle extended main secret" handshake_ems+        prop "can resume with extended main secret" handshake_resumption_ems+        prop "can handle ALPN" handshake_alpn+        it "rejects an unoffered ALPN selection from the server hook" $+            handshake_alpn_rejects_unoffered_server_selection+        it "rejects an unoffered ALPN selection received by the client" $+            handshake_alpn_rejects_unoffered_client_selection+        prop "can handle SNI" handshake_sni+        it "sends no SNI for an empty server name" handshake_sni_empty+        it "rejects multiple host_names in SNI" $+            handshake_sni_illegal ["example.com", "example.org"]+        it "rejects a host_name with a control character in SNI" $+            handshake_sni_illegal ["example\0.com"]+        it "rejects a non-ASCII host_name in SNI" $+            handshake_sni_illegal ["ex\xc4\x85mple.com"]+        prop "can handshake with TLS 1.2 CBC" handshake_cbc+        prop "can re-negotiate with TLS 1.2" handshake12_renegotiation+        it "rejects SCSV in a secure renegotiation" $+            handshake12_renegotiation_tampered $ \ch ->+                ch{chCiphers = chCiphers ch ++ [CipherId 0xff]}+        it "rejects a secure renegotiation without renegotiation_info" $+            handshake12_renegotiation_tampered $ \ch ->+                ch+                    { chExtensions =+                        filter+                            (\(ExtensionRaw eid _) -> eid /= EID_SecureRenegotiation)+                            (chExtensions ch)+                    }+        prop "can resume session with TLS 1.2" handshake12_session_resumption+        prop+            "rejects resuming a TLS 1.2 session without its cipher"+            handshake12_session_resumption_cipher_missing+        prop "can resume session ticket with TLS 1.2" handshake12_session_ticket+        it "sends no session ticket to a TLS 1.2 client that did not ask" $+            handshake12_session_ticket_unoffered+        prop "can handshake with TLS 1.3 Full" handshake13_full+        prop "can handshake with TLS 1.3 HRR" handshake13_hrr+        prop "can handshake with TLS 1.3 PSK" handshake13_psk+        it "does not resume a TLS 1.2 session with a TLS 1.3 PSK" $+            handshake13_psk_tls12_session+        prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket+        prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback+        prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt+        it "rejects TLS 1.3 early data when ALPN changes" $+            handshake13_0rtt_alpn+        prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback+        prop "can handshake with TLS 1.3 EE" handshake13_ee_groups+        prop "can handshake with TLS 1.3 EC groups" handshake13_ec+        prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+        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+        it+            "keeps record alignment when a slow record follows client auth"+            handshake13_client_auth_slow_record+        it "rejects a too short TLS 1.2 AEAD record with bad_record_mac" $+            short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+        it "rejects a too short TLS 1.2 CBC record with bad_record_mac" $+            short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_AES128CBC_SHA256+        it "rejects a too short TLS 1.3 record with bad_record_mac" $+            short_record_bad_record_mac TLS13 cipher13_AES_128_GCM_SHA256+        it "rejects a ServerHello as the first client message" $+            server_first_message_unexpected 2+        it "rejects a Finished as the first client message" $+            server_first_message_unexpected 20+        it "rejects an unknown handshake type as the first client message" $+            server_first_message_unexpected 254+        it "rejects a ChangeCipherSpec before the first ClientHello" $+            server_ccs_interleaved 0+        it "rejects a ChangeCipherSpec inside a fragmented ClientHello" $+            server_ccs_interleaved 2+        it "rejects an SSLv2-style record header at once" $+            server_first_record_type_unexpected 0x80 0x3fff+        it "rejects an unknown record type" $+            server_first_record_type_unexpected 24 0+        it "rejects application data inside a TLS 1.3 handshake message" $+            handshake13_interleaved_app_data+        it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $+            malformed_ccs_unexpected+                TLS12+                cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+                [P256]+                [P256]+        it "rejects a two-byte TLS 1.3 ChangeCipherSpec" $+            malformed_ccs_unexpected TLS13 cipher13_AES_128_GCM_SHA256 [X25519] [X25519]+        it "rejects a two-byte TLS 1.3 ChangeCipherSpec after HelloRetryRequest" $+            malformed_ccs_unexpected+                TLS13+                cipher13_AES_128_GCM_SHA256+                [P256, X25519]+                [X25519]++--------------------------------------------------------------++-- | Both channel bindings already answer with 'Maybe', and a caller may+-- reasonably ask for one on a context whose handshake has not run -- or has+-- failed.  The answer is that there is no binding, not a crash.+binding_before_handshake :: (ClientParams, ServerParams) -> IO ()+binding_before_handshake params = withPairContext params $ \(cCtx, sCtx) ->+    forM_ [cCtx, sCtx] $ \ctx -> do+        getTLSUnique ctx `shouldReturn` Nothing+        getTLSExporter ctx `shouldReturn` Nothing++pipe_work :: IO ()+pipe_work = do+    pipe <- newPipe+    _ <- runPipe pipe++    let bSize = 16+    n <- generate (choose (1, 32))++    let d1 = B.replicate (bSize * n) 40+    let d2 = B.replicate (bSize * n) 45++    d1' <- writePipeC pipe d1 >> readPipeS pipe (B.length d1)+    d1' `shouldBe` d1++    d2' <- writePipeS pipe d2 >> readPipeC pipe (B.length d2)+    d2' `shouldBe` d2++--------------------------------------------------------------++handshake_simple :: (ClientParams, ServerParams) -> IO ()+handshake_simple = runTLSSimple++--------------------------------------------------------------++newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP13 where+    arbitrary = CSP13 <$> arbitraryPairParams13++handshake13_simple :: CSP13 -> IO ()+handshake13_simple (CSP13 params) = runTLSSimple13 params hs+  where+    cgrps = supportedGroups $ clientSupported $ fst params+    sgrps = supportedGroups $ serverSupported $ snd params+    hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest++handshake_rejects_server_cipher_callback_escape :: IO ()+handshake_rejects_server_cipher_callback_escape = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    let params = cipherSelectionParams clientParam serverParam selectLegacy+    withPairContextWith (id, id) params $ \(cctx, sctx) ->+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedCipherEscape)+            (handshake cctx `shouldThrow` anyTLSException)+  where+    selectLegacy _ _ = cipher_ECDHE_RSA_AES128CBC_SHA256++handshake_rejects_legacy_cipher_in_tls13 :: IO ()+handshake_rejects_legacy_cipher_in_tls13 = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    let params = cipherSelectionParams clientParam serverParam defaultSelection+    withPairContextWith (id, id) params $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv cctx tamperCipher+        concurrently_+            (handshake sctx `shouldThrow` anyTLSException)+            (handshake cctx `shouldThrow` clientRejectedLegacyCipher)+  where+    defaultSelection _ = unsafeHead+    tamperCipher (ServerHello sh) =+        pure $+            ServerHello+                sh+                    { shCipher =+                        CipherId $ cipherID cipher_ECDHE_RSA_AES128CBC_SHA256+                    }+    tamperCipher hs = pure hs++cipherSelectionParams+    :: ClientParams+    -> ServerParams+    -> (Version -> [Cipher] -> Cipher)+    -> (ClientParams, ServerParams)+cipherSelectionParams clientParam serverParam select =+    ( clientParam{clientSupported = supported}+    , serverParam+        { serverSupported = supported+        , serverHooks =+            (serverHooks serverParam)+                { onCipherChoosing = select+                }+        }+    )+  where+    supported =+        defaultSupported+            { supportedVersions = [TLS13]+            , supportedCiphers =+                [ cipher13_AES_128_GCM_SHA256+                , cipher_ECDHE_RSA_AES128CBC_SHA256+                ]+            }++serverRejectedCipherEscape :: TLSException -> Bool+serverRejectedCipherEscape (HandshakeFailed (Error_Protocol msg alert)) =+    msg == "onCipherChoosing selected a cipher outside the candidate list"+        && alert == InternalError+serverRejectedCipherEscape _ = False++clientRejectedLegacyCipher :: TLSException -> Bool+clientRejectedLegacyCipher (HandshakeFailed (Error_Protocol msg alert)) =+    msg == "server selected a cipher invalid for the negotiated version"+        && alert == IllegalParameter+clientRejectedLegacyCipher _ = False++anyTLSException :: TLSException -> Bool+anyTLSException = const True++handshake_key_update_flood :: IO ()+handshake_key_update_flood = do+    params <- generate arbitraryPairParams13+    withPairContextWith (id, id) params $ \(cctx, sctx) ->+        concurrently_+            ( do+                handshake sctx+                recvData sctx `shouldReturn` "after 32 key updates"+                recvData sctx `shouldThrow` excessiveKeyUpdate+            )+            ( do+                handshake cctx+                replicateM_ 32 $ void $ updateKey cctx OneWay+                sendData cctx "after 32 key updates"+                replicateM_ 33 $ void $ updateKey cctx OneWay+                sendData cctx "after 33 key updates"+            )+  where+    excessiveKeyUpdate+        (Terminated _ _ (Error_Misc "too many consecutive KeyUpdate messages")) = True+    excessiveKeyUpdate _ = False++handshake_key_update_unlimited :: IO ()+handshake_key_update_unlimited = do+    (cparams, sparams0) <- generate arbitraryPairParams13+    let shared0 = serverShared sparams0+        limits = (sharedLimit shared0){limitKeyUpdate = Nothing}+        sparams = sparams0{serverShared = shared0{sharedLimit = limits}}+    withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) ->+        concurrently_+            ( do+                handshake sctx+                recvData sctx `shouldReturn` "after 33 key updates"+            )+            ( do+                handshake cctx+                replicateM_ 33 $ void $ updateKey cctx OneWay+                sendData cctx "after 33 key updates"+            )++handshake_key_update_non_positive :: IO ()+handshake_key_update_non_positive =+    forM_ [0, -1] $ \limit -> do+        (cparams, sparams0) <- generate arbitraryPairParams13+        let shared0 = serverShared sparams0+            limits = (sharedLimit shared0){limitKeyUpdate = Just limit}+            sparams = sparams0{serverShared = shared0{sharedLimit = limits}}+        withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) ->+            concurrently_+                ( do+                    handshake sctx+                    recvData sctx `shouldReturn` "after key update"+                )+                ( do+                    handshake cctx+                    void $ updateKey cctx OneWay+                    sendData cctx "after key update"+                )++--------------------------------------------------------------++handshake_cbc :: IO ()+handshake_cbc = do+    clientCiphers <- generate $ cipherGen >>= shuffle+    serverCiphers <- generate $ cipherGen >>= shuffle+    clientGroups <- generate $ groupGen >>= shuffle+    serverGroups <- generate $ groupGen >>= shuffle+    (clientParam, serverParam) <- generate $+        arbitraryPairParamsWithVersionsAndCiphers+            ([TLS12], [TLS12])+            (clientCiphers, serverCiphers)+    let clientParam' = clientParam {+            clientSupported = (clientSupported clientParam)+                { supportedGroups = clientGroups } }+        serverParam' = serverParam {+            serverSupported = (serverSupported serverParam)+                { supportedGroups = serverGroups } }+    let ciphers = clientCiphers `intersect` serverCiphers+        groups = clientGroups `intersect` serverGroups+     in if compat ciphers groups+        then runTLSSimple (clientParam', serverParam')+        else runTLSFailure (clientParam', serverParam') handshake handshake+  where+    groupGen :: Gen [Group]+    groupGen = sublistOf grps `suchThat` (not . null)+      where+        grps = [X25519, P256, P384, FFDHE2048, FFDHE3072, FFDHE4096]++    cipherGen :: Gen [Cipher]+    cipherGen = sublistOf ciphersuite_pfs_sha2_cbc `suchThat` (not . null)++    compat :: [Cipher] -> [Group] -> Bool+    compat [] _ = False+    compat _ [] = False+    compat ciphers groups =+        let mustdh = all (== CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+            mustec = all (/= CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+            havedh = any (`elem` [FFDHE2048, FFDHE3072, FFDHE4096]) groups+            haveec = any (`elem` [X25519, P256, P384]) groups+         in ((not mustdh || havedh) && (not mustec || haveec))++--------------------------------------------------------------++handshake13_downgrade :: (ClientParams, ServerParams) -> IO ()+handshake13_downgrade (cparam, sparam) = do+    versionForced <-+        generate $ elements (supportedVersions $ clientSupported cparam)+    let debug' = (serverDebug sparam){debugVersionForced = Just versionForced}+        sparam' = sparam{serverDebug = debug'}+        params = (cparam, sparam')+        downgraded =+            (isVersionEnabled TLS13 params && versionForced < TLS13)+                || (isVersionEnabled TLS12 params && versionForced < TLS12)+    if downgraded+        then runTLSFailure params handshake handshake+        else runTLSSimple params++handshake_update_key :: (ClientParams, ServerParams) -> IO ()+handshake_update_key = runTLSSimpleKeyUpdate++--------------------------------------------------------------++handshake_hashsignatures+    :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO ()+handshake_hashsignatures (clientHashSigs, serverHashSigs) = do+    tls13 <- generate arbitrary+    let version = if tls13 then TLS13 else TLS12+        ciphers =+            [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+            , cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384+            , cipher13_AES_128_GCM_SHA256+            ]+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                (ciphers, ciphers)+    let clientParam' =+            clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedHashSignatures = clientHashSigs+                        }+                }+        serverParam' =+            serverParam+                { serverSupported =+                    (serverSupported serverParam)+                        { supportedHashSignatures = serverHashSigs+                        }+                }+        commonHashSigs = clientHashSigs `intersect` serverHashSigs+        shouldFail+            | tls13 = all incompatibleWithDefaultCurve commonHashSigs+            | otherwise = null commonHashSigs+    if shouldFail+        then runTLSFailure (clientParam', serverParam') handshake handshake+        else runTLSSimple (clientParam', serverParam')+  where+    incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256+    incompatibleWithDefaultCurve _ = False++handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO ()+handshake_ciphersuites (clientCiphers, serverCiphers) = do+    tls13 <- generate arbitrary+    let version = if tls13 then TLS13 else TLS12+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                (clientCiphers, serverCiphers)+    let adequate = cipherAllowedForVersion version+        shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers)+    if shouldSucceed+        then runTLSSimple (clientParam, serverParam)+        else runTLSFailure (clientParam, serverParam) handshake handshake++--------------------------------------------------------------++handshake_groups :: GGP -> IO ()+handshake_groups (GGP clientGroups serverGroups) = do+    tls13 <- generate arbitrary+    let versions = if tls13 then [TLS13] else [TLS12]+        ciphers = ciphersuite_strong+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                (versions, versions)+                (ciphers, ciphers)+    denyCustom <- generate arbitrary+    let groupUsage =+            if denyCustom+                then GroupUsageUnsupported "custom group denied"+                else GroupUsageValid+        clientParam' =+            clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedGroups = clientGroups+                        }+                , clientHooks =+                    (clientHooks clientParam)+                        { onCustomFFDHEGroup = \_ _ -> return groupUsage+                        }+                }+        serverParam' =+            serverParam+                { serverSupported =+                    (serverSupported serverParam)+                        { supportedGroups = serverGroups+                        , supportedGroupsTLS13 = [serverGroups]+                        }+                }+        commonGroups = clientGroups `intersect` serverGroups+        shouldFail = null commonGroups+        p minfo = isNothing (minfo >>= infoSupportedGroup) == null commonGroups+    if shouldFail+        then runTLSFailure (clientParam', serverParam') handshake handshake+        else runTLSPredicate (clientParam', serverParam') p++--------------------------------------------------------------++newtype SG = SG [Group] deriving (Show)++instance Arbitrary SG where+    arbitrary = SG <$> shuffle sigGroups+      where+        sigGroups = [P256, P521]++handshake_ec :: SG -> IO ()+handshake_ec (SG sigGroups) = do+    let versions = [TLS12]+        ciphers =+            [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384+            ]+        hashSignatures =+            [ (HashSHA256, SignatureECDSA)+            ]+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                (versions, versions)+                (ciphers, ciphers)+    clientGroups <- generate $ shuffle sigGroups+    clientHashSignatures <- generate $ sublistOf hashSignatures+    serverHashSignatures <- generate $ sublistOf hashSignatures+    credentials <- generate arbitraryCredentialsOfEachCurve+    let clientParam' =+            clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedGroups = clientGroups+                        , supportedHashSignatures = clientHashSignatures+                        }+                }+        serverParam' =+            serverParam+                { serverSupported =+                    (serverSupported serverParam)+                        { supportedGroups = sigGroups+                        , supportedGroupsTLS13 = [sigGroups]+                        , supportedHashSignatures = serverHashSignatures+                        }+                , serverShared =+                    (serverShared serverParam)+                        { sharedCredentials = Credentials credentials+                        }+                }+        sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures)+        ecdsaDenied = SignatureECDSA `notElem` sigAlgs+    if ecdsaDenied+        then runTLSFailure (clientParam', serverParam') handshake handshake+        else runTLSSimple (clientParam', serverParam')++-- Tests ability to use or ignore client "signature_algorithms" extension when+-- choosing a server certificate.  Here peers allow DHE_RSA_AES128_SHA1 but+-- the server RSA certificate has a SHA-1 signature that the client does not+-- support.  Server may choose the DSA certificate only when cipher+-- DHE_DSA_AES128_SHA1 is allowed.  Otherwise it must fallback to the RSA+-- certificate.++data OC = OC [Cipher] [Cipher] deriving (Show)++instance Arbitrary OC where+    arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers+      where+        otherCiphers =+            [ cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384+            , cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+            ]++handshake_cert_fallback_cipher :: OC -> IO ()+handshake_cert_fallback_cipher (OC clientCiphers serverCiphers) = do+    let clientVersions = [TLS12]+        serverVersions = [TLS12]+        commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256]+        hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)]+    chainRef <- newIORef Nothing+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                (clientVersions, serverVersions)+                (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers)+    let clientParam' =+            clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedHashSignatures = hashSignatures+                        }+                , clientHooks =+                    (clientHooks clientParam)+                        { onServerCertificate = \_ _ _ chain ->+                            writeIORef chainRef (Just chain) >> return []+                        }+                }+    runTLSSimple (clientParam', serverParam)+    serverChain <- readIORef chainRef+    isLeafRSA serverChain `shouldBe` True++-- Same as above but testing with supportedHashSignatures directly instead of+-- ciphers, and thus allowing TLS13.  Peers accept RSA with SHA-256 but the+-- server RSA certificate has a SHA-1 signature.  When Ed25519 is allowed by+-- both client and server, the Ed25519 certificate is selected.  Otherwise the+-- server fallbacks to RSA.+--+-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13+-- unless client advertises explicit support.  Currently this is not enforced by+-- the library, which is useful to test this scenario.  SHA-1 could be replaced+-- by another algorithm.++data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm]+    deriving (Show)++instance Arbitrary OHS where+    arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS+      where+        otherHS = [(HashIntrinsic, SignatureEd25519)]++handshake_cert_fallback_hs :: OHS -> IO ()+handshake_cert_fallback_hs (OHS clientHS serverHS) = do+    tls13 <- generate arbitrary+    let versions = if tls13 then [TLS13] else [TLS12]+        ciphers =+            [ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+            , cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256+            , cipher13_AES_128_GCM_SHA256+            ]+        commonHS =+            [ (HashSHA256, SignatureRSA)+            , (HashIntrinsic, SignatureRSApssRSAeSHA256)+            ]+    chainRef <- newIORef Nothing+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                (versions, versions)+                (ciphers, ciphers)+    let clientParam' =+            clientParam+                { clientSupported =+                    (clientSupported clientParam)+                        { supportedHashSignatures = commonHS ++ clientHS+                        }+                , clientHooks =+                    (clientHooks clientParam)+                        { onServerCertificate = \_ _ _ chain ->+                            writeIORef chainRef (Just chain) >> return []+                        }+                }+        serverParam' =+            serverParam+                { serverSupported =+                    (serverSupported serverParam)+                        { supportedHashSignatures = commonHS ++ serverHS+                        }+                }+        eddsaDisallowed =+            (HashIntrinsic, SignatureEd25519) `notElem` clientHS+                || (HashIntrinsic, SignatureEd25519) `notElem` serverHS+    runTLSSimple (clientParam', serverParam')+    serverChain <- readIORef chainRef+    isLeafRSA serverChain `shouldBe` eddsaDisallowed++--------------------------------------------------------------++handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO ()+handshake_server_key_usage usageFlags = do+    tls13 <- generate arbitrary+    let versions = if tls13 then [TLS13] else [TLS12]+        ciphers = ciphersuite_all+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                (versions, versions)+                (ciphers, ciphers)+    cred <- generate $ arbitraryRSACredentialWithUsage usageFlags+    let serverParam' =+            serverParam+                { serverShared =+                    (serverShared serverParam)+                        { sharedCredentials = Credentials [cred]+                        }+                }+        shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags+    if shouldSucceed+        then runTLSSimple (clientParam, serverParam')+        else runTLSFailure (clientParam, serverParam') handshake handshake++handshake_server_key_purpose :: Version -> ExtKeyUsagePurpose -> Bool -> IO ()+handshake_server_key_purpose version purpose shouldSucceed = 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 purpose+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onServerCertificate = \_ _ _ _ -> return []+                        }+                }+        serverParam' =+            serverParam+                { serverShared =+                    (serverShared serverParam)+                        { sharedCredentials = Credentials [cred]+                        }+                }+    if shouldSucceed+        then runTLSSimple (clientParam', serverParam')+        else runTLSFailure (clientParam', serverParam') handshake handshake++handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO ()+handshake_client_key_usage usageFlags = do+    (clientParam, serverParam) <- generate arbitrary+    cred <- generate $ arbitraryRSACredentialWithUsage usageFlags+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+        shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags+    if shouldSucceed+        then runTLSSimple (clientParam', serverParam')+        else runTLSFailure (clientParam', serverParam') handshake handshake++--------------------------------------------------------------++handshake_client_auth :: (ClientParams, ServerParams) -> IO ()+handshake_client_auth (clientParam, serverParam) = do+    let clientVersions = supportedVersions $ clientSupported clientParam+        serverVersions = supportedVersions $ serverSupported serverParam+        version = maximum (clientVersions `intersect` serverVersions)+    cred <- generate (arbitraryClientCredential version)+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = validateChain cred+                        }+                }+    runTLSSimple (clientParam', serverParam')+  where+    validateChain cred chain+        | chain == fst cred = return CertificateUsageAccept+        | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)++-- A client without a certificate answers CertificateRequest with an empty+-- Certificate and, in TLS 1.2, sends no CertificateVerify.  A server whose+-- hook accepts that must go on to ChangeCipherSpec rather than wait for a+-- CertificateVerify.+handshake_client_auth_empty :: Version -> IO ()+handshake_client_auth_empty 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])+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return Nothing+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = acceptEmpty+                        }+                }+    runTLSSimple (clientParam', serverParam')+  where+    acceptEmpty chain+        | isNullCertificateChain chain = return CertificateUsageAccept+        | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)++-- In TLS 1.2 a client certificate with an Ed25519 or Ed448 key is asked+-- for with ecdsa_sign (RFC 8422 Section 3.1).  The Ed25519 and Ed448+-- certificate types of this library are synthetic and have no code point,+-- so they must not reach the wire.+handshake12_cert_request_types :: IO ()+handshake12_cert_request_types = do+    let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS12], [TLS12])+                ([cipher], [cipher])+    ref <- newIORef Nothing+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return Nothing+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverSupported =+                    (serverSupported serverParam)+                        { supportedHashSignatures =+                            supportedHashSignatures defaultSupported+                        }+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+        record hs@(CertRequest certTypes _ _) = writeIORef ref (Just certTypes) >> return hs+        record hs = return hs+    withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv cctx record+        concurrently_ (handshake sctx) (handshake cctx)+    mtypes <- readIORef ref+    case mtypes of+        Nothing -> expectationFailure "no CertificateRequest received"+        Just certTypes -> do+            certTypes `shouldSatisfy` all (`elem` defined)+            certTypes `shouldContain` [CertificateType_ECDSA_Sign]+  where+    defined =+        [ CertificateType_RSA_Sign+        , CertificateType_DSA_Sign+        , CertificateType_ECDSA_Sign+        ]++-- RFC 5246 Section 7.4.8: a TLS 1.2 CertificateVerify algorithm for+-- another type of key than the certificate's has a field that is+-- incorrect, an illegal_parameter, even when onUnverifiedClientCert would+-- accept a signature that does not verify.  One for an RSA key that still+-- does not fit it, RSASSA-PSS for an rsaEncryption key, is a signature+-- 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 ()+handshake12_client_cert_verify_sigalg alg rejected = do+    let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS12], [TLS12])+                ([cipher], [cipher])+    cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        acceptUnverified = alg == (HashSHA256, SignatureECDSA)+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        , onUnverifiedClientCert = return acceptUnverified+                        }+                }+        unfit (CertVerify (DigitallySigned _ sig)) =+            pure $ CertVerify (DigitallySigned alg sig)+        unfit hs = pure hs+    r <- timeout 10000000 $+        withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+            contextHookSetHandshakeRecv sctx unfit+            concurrently_+                (handshake sctx `shouldThrow` rejected)+                (void (E.try (handshake cctx) :: IO (Either TLSException ())))+    r `shouldSatisfy` isJust++rejectedAsDecryptError :: TLSException -> Bool+rejectedAsDecryptError (HandshakeFailed (Error_Protocol _ DecryptError)) = True+rejectedAsDecryptError _ = False++-- RFC 8446 Section 6.2: a CertificateVerify whose algorithm may not be used+-- with the certificate's key has a field that is incorrect, which is an+-- illegal_parameter; decrypt_error is for a signature that does not verify.+-- The client signs with RSA-PSS for an rsaEncryption key and the server+-- reads the algorithm as rsa_pss_pss_sha256, which needs an RSASSA-PSS key.+handshake13_client_cert_verify_unfit_sigalg :: IO ()+handshake13_client_cert_verify_unfit_sigalg = do+    let cipher = cipher13_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS13], [TLS13])+                ([cipher], [cipher])+    cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+        unfit (CertVerify13 (DigitallySigned _ sig)) =+            pure $+                CertVerify13 (DigitallySigned (HashIntrinsic, SignatureRSApsspssSHA256) sig)+        unfit hs = pure hs+    r <- timeout 10000000 $+        withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+            contextHookSetHandshake13Recv sctx unfit+            concurrently_+                ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsIllegalParameter)+                ( void+                    (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+                )+    r `shouldSatisfy` isJust++rejectedAsIllegalParameter :: TLSException -> Bool+rejectedAsIllegalParameter (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True+rejectedAsIllegalParameter (Terminated _ _ (Error_Protocol _ IllegalParameter)) = True+rejectedAsIllegalParameter _ = False++-- A server that receives a ClientHello whose legacy_version is higher than+-- its own negotiates the highest version it supports (RFC 5246 Appendix+-- E.1); with supported_versions present it does not use legacy_version at+-- all (RFC 8446 Section 4.2.1).  The ClientHello's legacy_version is raised+-- on its way to the server, and the handshake must still reach the version+-- both sides support.+handshake_high_legacy_version :: Version -> Version -> IO ()+handshake_high_legacy_version version legacy = 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])+    let raise (ClientHello ch) = pure $ ClientHello ch{chVersion = legacy}+        raise hs = pure hs+    withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv sctx raise+        concurrently_ (handshake sctx) (handshake cctx)+        info <- contextGetInformation sctx+        (infoVersion <$> info) `shouldBe` Just version++-- RFC 8422 Section 5.1.2: ec_point_format_list is <1..2^8-1>, and a+-- client naming one of its curves in supported_groups must offer the+-- uncompressed format.  The ClientHello's ec_point_formats is replaced+-- on its way to the server, which must refuse it.+handshake12_ec_point_formats+    :: B.ByteString -> Selector TLSException -> IO ()+handshake12_ec_point_formats formats rejected = do+    CSP12 (cparams, sparams) <- generate arbitrary+    let cparams' =+            cparams+                { clientSupported =+                    (clientSupported cparams){supportedGroups = [X25519]}+                }+        sparams' =+            sparams+                { serverSupported =+                    (serverSupported sparams){supportedGroups = [X25519]}+                }+        replace (ClientHello ch) =+            pure $+                ClientHello+                    ch+                        { chExtensions =+                            filter+                                (\(ExtensionRaw eid _) -> eid /= EID_EcPointFormats)+                                (chExtensions ch)+                                ++ [ExtensionRaw EID_EcPointFormats formats]+                        }+        replace hs = pure hs+    r <- timeout 10000000 $+        withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do+            contextHookSetHandshakeRecv sctx replace+            concurrently_+                (handshake sctx `shouldThrow` rejected)+                (void (E.try (handshake cctx) :: IO (Either TLSException ())))+    r `shouldSatisfy` isJust++rejectedAsDecodeError :: TLSException -> Bool+rejectedAsDecodeError (HandshakeFailed (Error_Protocol _ DecodeError)) = True+rejectedAsDecodeError _ = False++handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO ()+handshake_client_auth_fail (clientParam, serverParam) = do+    let clientVersions = supportedVersions $ clientSupported clientParam+        serverVersions = supportedVersions $ serverSupported serverParam+        version = maximum (clientVersions `intersect` serverVersions)+    cred <- generate (arbitraryClientCredential version)+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = validateChain cred+                        }+                }+    runTLSFailure (clientParam', serverParam') handshake handshake+  where+    validateChain _ _ = return (CertificateUsageReject CertificateRejectUnknownCA)++--------------------------------------------------------------++handshake_ems :: (EMSMode, EMSMode) -> IO ()+handshake_ems (cems, sems) = do+    params <- generate arbitrary+    let params' = setEMSMode (cems, sems) params+        version = getConnectVersion params'+        emsVersion = version >= TLS10 && version <= TLS12+        use = cems /= NoEMS && sems /= NoEMS+        require = cems == RequireEMS || sems == RequireEMS+        p info = infoExtendedMainSecret info == (emsVersion && use)+    if emsVersion && require && not use+        then runTLSFailure params' handshake handshake+        else runTLSPredicate params' (maybe False p)++newtype CompatEMS = CompatEMS (EMSMode, EMSMode) deriving (Show)++instance Arbitrary CompatEMS where+    arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible)+      where+        compatible (NoEMS, RequireEMS) = False+        compatible (RequireEMS, NoEMS) = False+        compatible _ = True++handshake_resumption_ems :: (CompatEMS, CompatEMS) -> IO ()+handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do+    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    plainParams <- generate arbitrary+    let params =+            setEMSMode ems $+                setPairParamsSessionManagers sessionManagers plainParams++    runTLSSimple params++    -- and resume+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 =+            setEMSMode ems2 $+                setPairParamsSessionResuming (fromJust sessionParams) params++    let version = getConnectVersion params2+        emsVersion = version >= TLS10 && version <= TLS12++    if emsVersion && use ems && not (use ems2)+        then runTLSFailure params2 handshake handshake+        else do+            runTLSSimple params2+            mSessionParams2 <- readClientSessionRef sessionRefs+            let sameSession = sessionParams == mSessionParams2+                sameUse = use ems == use ems2+            when emsVersion (sameSession `shouldBe` sameUse)+  where+    use (NoEMS, _) = False+    use (_, NoEMS) = False+    use _ = True++--------------------------------------------------------------++handshake_alpn :: (ClientParams, ServerParams) -> IO ()+handshake_alpn (clientParam, serverParam) = do+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onSuggestALPN = return $ Just ["h2", "http/1.1"]+                        }+                }+        serverParam' =+            serverParam+                { serverHooks =+                    (serverHooks serverParam)+                        { onALPNClientSuggest = Just alpn+                        }+                }+        params' = (clientParam', serverParam')+    runTLSSuccess params' hsClient hsServer+  where+    hsClient ctx = do+        handshake ctx+        proto <- getNegotiatedProtocol ctx+        proto `shouldBe` Just "h2"+    hsServer ctx = do+        handshake ctx+        proto <- getNegotiatedProtocol ctx+        proto `shouldBe` Just "h2"+    alpn xs+        | "h2" `elem` xs = return "h2"+        | otherwise = return "http/1.1"++handshake_alpn_rejects_unoffered_server_selection :: IO ()+handshake_alpn_rejects_unoffered_server_selection = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    let params = alpnParams clientParam serverParam (const $ pure "h2")+    withPairContextWith (id, id) params $ \(cctx, sctx) ->+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedUnofferedALPN)+            (handshake cctx `shouldThrow` anyTLSException)++handshake_alpn_rejects_unoffered_client_selection :: IO ()+handshake_alpn_rejects_unoffered_client_selection = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    let params = alpnParams clientParam serverParam (pure . unsafeHead)+    withPairContextWith (id, id) params $ \(cctx, sctx) -> do+        contextHookSetHandshake13Recv cctx tamperALPN+        concurrently_+            (handshake sctx `shouldThrow` anyTLSException)+            (handshake cctx `shouldThrow` clientRejectedUnofferedALPN)+  where+    tamperALPN (EncryptedExtensions13 exts) =+        pure $ EncryptedExtensions13 $ map replaceALPN exts+    tamperALPN hs = pure hs+    replaceALPN ext@(ExtensionRaw eid _)+        | eid == EID_ApplicationLayerProtocolNegotiation =+            toExtensionRaw $ ApplicationLayerProtocolNegotiation ["h2"]+        | otherwise = ext++alpnParams+    :: ClientParams+    -> ServerParams+    -> ([B.ByteString] -> IO B.ByteString)+    -> (ClientParams, ServerParams)+alpnParams clientParam serverParam select =+    ( clientParam+        { clientHooks =+            (clientHooks clientParam)+                { onSuggestALPN = pure $ Just ["http/1.1"]+                }+        }+    , serverParam+        { serverHooks =+            (serverHooks serverParam)+                { onALPNClientSuggest = Just select+                }+        }+    )++serverRejectedUnofferedALPN :: TLSException -> Bool+serverRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) =+    msg == "ALPN callback selected a protocol not offered by the client"+        && alert == NoApplicationProtocol+serverRejectedUnofferedALPN _ = False++clientRejectedUnofferedALPN :: TLSException -> Bool+clientRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) =+    msg == "server selected an ALPN protocol not offered by the client"+        && alert == IllegalParameter+clientRejectedUnofferedALPN _ = False++-- RFC 6066 Section 3: HostName is <1..2^16-1>, so a client with an+-- empty server name sends no server_name, and the server sees none.+handshake_sni_empty :: IO ()+handshake_sni_empty = do+    CSP12 (clientParam, serverParam) <- generate arbitrary+    let clientParam' = clientParam{clientServerIdentification = ("", "")}+    runTLSSuccess (clientParam', serverParam) hs hs+  where+    hs ctx = do+        handshake ctx+        msni <- getClientSNI ctx+        msni `shouldBe` Nothing++-- RFC 6066 Section 3: the server_name_list MUST NOT contain more than one+-- name of the same name_type, and HostName is an ASCII DNS host name.  The+-- ClientHello's server_name is replaced on its way to the server, which+-- must refuse it with illegal_parameter.+handshake_sni_illegal :: [B.ByteString] -> IO ()+handshake_sni_illegal names = do+    CSP12 (clientParam, serverParam) <- generate arbitrary+    let entry name =+            B.concat [B.pack [0, len `shiftR` 8, len], name]+          where+            len = fromIntegral $ B.length name+        list = B.concat $ map entry names+        listLen = fromIntegral $ B.length list+        sni = B.concat [B.pack [listLen `shiftR` 8, listLen], list]+        replace (ClientHello ch) =+            pure $+                ClientHello+                    ch+                        { chExtensions =+                            ExtensionRaw EID_ServerName sni+                                : filter+                                    (\(ExtensionRaw eid _) -> eid /= EID_ServerName)+                                    (chExtensions ch)+                        }+        replace hs = pure hs+    r <- timeout 10000000 $+        withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do+            contextHookSetHandshakeRecv sctx replace+            concurrently_+                (handshake sctx `shouldThrow` rejectedAsIllegalParameter)+                (void (E.try (handshake cctx) :: IO (Either TLSException ())))+    r `shouldSatisfy` isJust++handshake_sni :: (ClientParams, ServerParams) -> IO ()+handshake_sni (clientParam, serverParam) = do+    ref <- newIORef Nothing+    let clientParam' =+            clientParam+                { clientServerIdentification = (serverName, "")+                }+        serverParam' =+            serverParam+                { serverHooks =+                    (serverHooks serverParam)+                        { onServerNameIndication = onSNI ref+                        }+                }+        params' = (clientParam', serverParam')+    runTLSSuccess params' hsClient hsServer+    receivedName <- readIORef ref+    receivedName `shouldBe` Just (Just serverName)+  where+    hsClient ctx = do+        handshake ctx+        msni <- getClientSNI ctx+        expectMaybe "C: SNI should be Just" serverName msni+    hsServer ctx = do+        handshake ctx+        msni <- getClientSNI ctx+        expectMaybe "S: SNI should be Just" serverName msni+    onSNI ref name = do+        mx <- readIORef ref+        mx `shouldBe` Nothing+        writeIORef ref (Just name)+        return (Credentials [])+    serverName = "haskell.org"++--------------------------------------------------------------++newtype CSP12 = CSP12 (ClientParams, ServerParams) deriving (Show)++instance Arbitrary CSP12 where+    arbitrary = CSP12 <$> arbitraryPairParams12++handshake12_renegotiation :: CSP12 -> IO ()+handshake12_renegotiation (CSP12 (cparams, sparams)) = do+    renegDisabled <- generate arbitrary+    let sparams' =+            sparams+                { serverSupported =+                    (serverSupported sparams)+                        { supportedClientInitiatedRenegotiation = not renegDisabled+                        }+                }+    if renegDisabled+        then runTLSFailure (cparams, sparams') hsClient hsServer+        else runTLSSimple (cparams, sparams')+  where+    hsClient ctx = handshake ctx >> handshake ctx+    -- recvData receives the alert from the second handshake+    hsServer ctx = handshake ctx >> void (recvData ctx)++-- RFC 5746 Section 3.7: when a connection with secure renegotiation is+-- renegotiated, ClientHello must not contain the SCSV and must contain+-- the renegotiation_info extension.  The second ClientHello is tampered+-- with on its way to the server, which must abort with handshake_failure.+handshake12_renegotiation_tampered :: (ClientHello -> ClientHello) -> IO ()+handshake12_renegotiation_tampered tamper = do+    CSP12 (cparams, sparams) <- generate arbitrary+    let cparams' =+            cparams+                { clientSupported =+                    (clientSupported cparams)+                        { supportedSecureRenegotiation = True+                        }+                }+        sparams' =+            sparams+                { serverSupported =+                    (serverSupported sparams)+                        { supportedSecureRenegotiation = True+                        , supportedClientInitiatedRenegotiation = True+                        }+                }+    count <- newIORef (0 :: Int)+    let tamperSecond (ClientHello ch) = do+            n <- atomicModifyIORef' count $ \i -> (i + 1, i)+            pure $ ClientHello $ if n == 0 then ch else tamper ch+        tamperSecond hs = pure hs+    r <- timeout 10000000 $+        withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do+            contextHookSetHandshakeRecv sctx tamperSecond+            concurrently_ (handshake sctx) (handshake cctx)+            concurrently_+                (recvData sctx `shouldThrow` rejectedAsHandshakeFailure)+                ( void+                    (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+                )+    r `shouldSatisfy` isJust++rejectedAsHandshakeFailure :: TLSException -> Bool+rejectedAsHandshakeFailure (HandshakeFailed (Error_Protocol _ HandshakeFailure)) = True+rejectedAsHandshakeFailure (Terminated _ _ (Error_Protocol _ HandshakeFailure)) = True+rejectedAsHandshakeFailure _ = False++handshake12_session_resumption :: CSP12 -> IO ()+handshake12_session_resumption (CSP12 plainParams) = do+    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    let params = setPairParamsSessionManagers sessionManagers plainParams++    runTLSSimple params++    -- and resume+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++    runTLSPredicate params2 (maybe False infoTLS12Resumption)++-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer its+-- cipher suite.  When it asks to resume one and offers none the server can+-- use, that is what is reported -- illegal_parameter, as when a cipher could+-- be chosen -- rather than the missing common cipher.+handshake12_session_resumption_cipher_missing :: CSP12 -> IO ()+handshake12_session_resumption_cipher_missing (CSP12 plainParams) = do+    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs+        params = setPairParamsSessionManagers sessionManagers plainParams+    runTLSSimple params+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params+        -- TLS_RSA_WITH_NULL_MD5, which the server does not support+        nullCiphers (ClientHello ch) = pure $ ClientHello ch{chCiphers = [CipherId 0x0001]}+        nullCiphers hs = pure hs+    withPairContextWith (id, id) params2 $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv sctx nullCiphers+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedMissingCipher)+            (handshake cctx `shouldThrow` anyTLSException)++serverRejectedMissingCipher :: TLSException -> Bool+serverRejectedMissingCipher (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True+serverRejectedMissingCipher _ = False++-- RFC 5077 Sections 3.2 and 3.3: a server sends the session_ticket+-- extension and NewSessionTicket only to a client that sent the+-- extension.  The client's session_ticket is removed on its way to a+-- server whose session manager uses tickets, and the client must then+-- receive neither.+handshake12_session_ticket_unoffered :: IO ()+handshake12_session_ticket_unoffered = do+    CSP12 (cparams, sparams) <- generate arbitrary+    let sparams' =+            sparams+                { serverShared =+                    (serverShared sparams){sharedSessionManager = oneSessionTicket}+                }+        unoffer (ClientHello ch) =+            pure $+                ClientHello+                    ch+                        { chExtensions =+                            filter+                                (\(ExtensionRaw eid _) -> eid /= EID_SessionTicket)+                                (chExtensions ch)+                        }+        unoffer hs = pure hs+    received <- newIORef []+    let record hs = modifyIORef received (hs :) >> pure hs+    withPairContextWith (id, id) (cparams, sparams') $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv sctx unoffer+        contextHookSetHandshakeRecv cctx record+        concurrently_ (handshake sctx) (handshake cctx)+    hss <- readIORef received+    let ticketExt (ServerHello sh) =+            any (\(ExtensionRaw eid _) -> eid == EID_SessionTicket) (shExtensions sh)+        ticketExt _ = False+        newTicket NewSessionTicket{} = True+        newTicket _ = False+    filter (\h -> ticketExt h || newTicket h) hss `shouldBe` []++handshake12_session_ticket :: CSP12 -> IO ()+handshake12_session_ticket (CSP12 plainParams) = do+    sessionRefs <- twoSessionRefs+    let sessionManagers0 = twoSessionManagers sessionRefs+        sessionManagers = (fst sessionManagers0, oneSessionTicket)++    let params = setPairParamsSessionManagers sessionManagers plainParams++    runTLSSimple params++    -- and resume+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++    runTLSPredicate params2 (maybe False infoTLS12Resumption)++--------------------------------------------------------------++handshake13_full :: CSP13 -> IO ()+handshake13_full (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    runTLSSimple13 params FullHandshake++handshake13_hrr :: CSP13 -> IO ()+handshake13_hrr (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    runTLSSimple13 params HelloRetryRequest++handshake13_psk :: CSP13 -> IO ()+handshake13_psk (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params0 =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )++    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    let params = setPairParamsSessionManagers sessionManagers params0++    runTLSSimple13 params HelloRetryRequest++    -- and resume+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++    runTLSSimple13 params2 PreSharedKey++-- RFC 8446 Section 4.6.1: a TLS 1.3 PSK resumes only a TLS 1.3 session.+-- The server's session manager answers the client's PSK identity with a+-- TLS 1.2 session, which has no ticket information; the server must+-- fall back to a full handshake rather than fail.+handshake13_psk_tls12_session :: IO ()+handshake13_psk_tls12_session = do+    CSP12 params12 <- generate arbitrary+    refs12 <- twoSessionRefs+    runTLSSimple $ setPairParamsSessionManagers (twoSessionManagers refs12) params12+    Just (_, sdata12) <- readIORef (snd refs12)+    sessionVersion sdata12 `shouldBe` TLS12++    CSP13 (cli, srv) <- generate arbitrary+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params0 =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    refs13 <- twoSessionRefs+    let params = setPairParamsSessionManagers (twoSessionManagers refs13) params0+    runTLSSimple13 params HelloRetryRequest+    Just sessionParams <- readClientSessionRef refs13++    let tls12Manager =+            noSessionManager+                { sessionResume = \_ -> return $ Just sdata12+                , sessionResumeOnlyOnce = \_ -> return $ Just sdata12+                }+        params2 =+            setPairParamsSessionResuming sessionParams $+                setPairParamsSessionManagers (fst (twoSessionManagers refs13), tls12Manager) params0+    -- The key share is for the group of the earlier session, so no+    -- HelloRetryRequest, and the PSK is not used.+    runTLSSimple13 params2 FullHandshake++handshake13_psk_ticket :: CSP13 -> IO ()+handshake13_psk_ticket (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params0 =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )++    sessionRefs <- twoSessionRefs+    let sessionManagers0 = twoSessionManagers sessionRefs+        sessionManagers = (fst sessionManagers0, oneSessionTicket)++    let params = setPairParamsSessionManagers sessionManagers params0++    runTLSSimple13 params HelloRetryRequest++    -- and resume+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let params2 = setPairParamsSessionResuming (fromJust sessionParams) params++    runTLSSimple13 params2 PreSharedKey++handshake13_psk_fallback :: CSP13 -> IO ()+handshake13_psk_fallback (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers =+                    [ cipher13_AES_128_GCM_SHA256+                    , cipher13_AES_128_CCM_SHA256+                    ]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        params0 =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )++    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    let params = setPairParamsSessionManagers sessionManagers params0++    runTLSSimple13 params HelloRetryRequest++    -- resumption fails because GCM cipher is not supported anymore, full+    -- handshake is not possible because X25519 has been removed, so we are+    -- back with P256 after hello retry+    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params+        srv2' =+            srv2{serverSupported = svrSupported'}+        svrSupported' =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_CCM_SHA256]+                , supportedGroups = [P256]+                , supportedGroupsTLS13 = [[P256]]+                }++    runTLSSimple13 (cli2, srv2') HelloRetryRequest++handshake13_0rtt :: CSP13 -> IO ()+handshake13_0rtt (CSP13 (cli, srv)) = do+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        cliHooks =+            defaultClientHooks+                { onSuggestALPN = return $ Just ["h2"]+                }+        svrHooks =+            defaultServerHooks+                { onALPNClientSuggest = Just (return . unsafeHead)+                }+        params0 =+            ( cli+                { clientSupported = cliSupported+                , clientHooks = cliHooks+                }+            , srv+                { serverSupported = svrSupported+                , serverHooks = svrHooks+                , serverEarlyDataSize = 2048+                }+            )++    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    let params = setPairParamsSessionManagers sessionManagers params0++    runTLSSimple13 params HelloRetryRequest+    runTLS0rtt params sessionRefs+    runTLS0rtt params sessionRefs+  where+    runTLS0rtt params sessionRefs = do+        -- and resume+        sessionParams <- readClientSessionRef sessionRefs+        expectJust "session param should be Just" sessionParams+        clearClientSessionRef sessionRefs+        earlyData <- B.pack <$> generate (someWords8 256)+        let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+            params2 = (pc{clientUseEarlyData = True}, ps)++        runTLS0RTT params2 RTT0 earlyData++handshake13_0rtt_alpn :: IO ()+handshake13_0rtt_alpn = do+    (cli, srv) <- generate arbitraryPairParams13+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [X25519]+                , supportedGroupsTLS13 = [[X25519]]+                }+        cliHooks =+            defaultClientHooks+                { onSuggestALPN = return $ Just ["h2"]+                }+        svrHooks =+            defaultServerHooks+                { onALPNClientSuggest = Just (return . unsafeHead)+                }+        params0 =+            ( cli+                { clientSupported = cliSupported+                , clientHooks = cliHooks+                }+            , srv+                { serverSupported = svrSupported+                , serverHooks = svrHooks+                , serverEarlyDataSize = 2048+                }+            )+    sessionRefs <- twoSessionRefs+    let params =+            setPairParamsSessionManagers+                (twoSessionManagers sessionRefs)+                params0+    runTLSSimple13 params FullHandshake++    sessionParams <- readClientSessionRef sessionRefs+    expectJust "session param should be Just" sessionParams+    sessionALPN (snd $ fromJust sessionParams) `shouldBe` Just "h2"+    let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params+        pc' =+            pc+                { clientUseEarlyData = True+                , clientHooks =+                    (clientHooks pc)+                        { onSuggestALPN = return $ Just ["http/1.1"]+                        }+                }+        ps' =+            ps+                { serverHooks =+                    (serverHooks ps)+                        { onALPNClientSuggest = Just (return . unsafeHead)+                        }+                }+    runTLS0RTT (pc', ps') PreSharedKey "GET /admin HTTP/1.1\r\n\r\n"++handshake13_0rtt_fallback :: CSP13 -> IO ()+handshake13_0rtt_fallback (CSP13 (cli, srv)) = do+    group0 <- generate $ elements [P256, X25519]+    let cliSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [P256, X25519]+                }+        svrSupported =+            defaultSupported+                { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                , supportedGroups = [group0]+                , supportedGroupsTLS13 = [[group0]]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv+                { serverSupported = svrSupported+                , serverEarlyDataSize = 1024+                }+            )++    sessionRefs <- twoSessionRefs+    let sessionManagers = twoSessionManagers sessionRefs++    let params0 = setPairParamsSessionManagers sessionManagers params++    let mode = if group0 == P256 then FullHandshake else HelloRetryRequest+    runTLSSimple13 params0 mode++    -- and resume+    mSessionParams <- readClientSessionRef sessionRefs+    case mSessionParams of+        Nothing -> expectationFailure "session params: Just is expected"+        Just sessionParams -> do+            earlyData <- B.pack <$> generate (someWords8 256)+            group1 <- generate $ elements [P256, X25519]+            let (pc, ps) = setPairParamsSessionResuming sessionParams params0+                svrSupported1 =+                    defaultSupported+                        { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+                        , supportedGroups = [group1]+                        , supportedGroupsTLS13 = [[group1]]+                        }+                params1 =+                    ( pc{clientUseEarlyData = True}+                    , ps+                        { serverEarlyDataSize = 0+                        , serverSupported = svrSupported1+                        }+                    )+            -- C: [P256, X25519]+            -- S: [group0]+            -- C: [P256, X25519]+            -- S: [group1]+            if group0 == group1+                -- 0-RTT is not allowed, so fallback to PreSharedKey+                then runTLS0RTT params1 PreSharedKey earlyData+                -- HRR but not allowed for 0-RTT+                else runTLSFailure params1 (tlsClient earlyData) tlsServer+  where+    tlsClient earlyData ctx = do+        handshake ctx+        sendData ctx $ L.fromStrict earlyData+        _ <- recvData ctx+        bye ctx+    tlsServer ctx = do+        handshake ctx+        _ <- recvData ctx+        bye ctx++handshake13_ee_groups :: CSP13 -> IO ()+handshake13_ee_groups (CSP13 (cli, srv)) = do+    let -- The client prefers P256+        cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]}+        -- The server prefers X25519+        svrSupported =+            (serverSupported srv)+                { supportedGroups = [X25519, P256]+                , supportedGroupsTLS13 = [[X25519, P256]]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    (_, serverMessages) <- runTLSCapture13 params+    -- The server should tell X25519 in supported_groups in EE to client+    let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups+        eeMessagesHaveExt =+            [ any isSupportedGroups exts+            | EncryptedExtensions13 exts <- serverMessages+            ]+    eeMessagesHaveExt `shouldBe` [True]++handshake13_ec :: CSP13 -> IO ()+handshake13_ec (CSP13 (cli, srv)) = do+    EC cgrps <- generate arbitrary+    EC sgrps <- generate arbitrary+    let cliSupported = (clientSupported cli){supportedGroups = cgrps}+        svrSupported =+            (serverSupported srv)+                { supportedGroups = sgrps+                , supportedGroupsTLS13 = [sgrps]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    runTLSSimple13 params FullHandshake++handshake13_ffdhe :: CSP13 -> IO ()+handshake13_ffdhe (CSP13 (cli, srv)) = do+    FFDHE cgrps <- generate arbitrary+    FFDHE sgrps <- generate arbitrary+    let cliSupported = (clientSupported cli){supportedGroups = cgrps}+        svrSupported =+            (serverSupported srv)+                { supportedGroups = sgrps+                , supportedGroupsTLS13 = [sgrps]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    runTLSSimple13 params FullHandshake++-- An all-zero X25519 public key decodes, but the shared secret computed+-- from it is all zero and is rejected.  The server must answer with+-- illegal_parameter, as it does for X25519 alone, rather than crash.+handshake13_x25519mlkem768_zero_x25519 :: IO ()+handshake13_x25519mlkem768_zero_x25519 = do+    CSP13 (cli, srv) <- generate arbitrary+    let cliSupported =+            (clientSupported cli){supportedGroups = [X25519MLKEM768]}+        svrSupported =+            (serverSupported srv)+                { supportedGroups = [X25519MLKEM768]+                , supportedGroupsTLS13 = [[X25519MLKEM768]]+                }+        params =+            ( cli{clientSupported = cliSupported}+            , srv{serverSupported = svrSupported}+            )+    withPairContextWith (id, id) params $ \(cctx, sctx) -> do+        contextHookSetHandshakeRecv sctx zeroX25519+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedZeroX25519)+            (handshake cctx `shouldThrow` anyTLSException)+  where+    zeroX25519 (ClientHello ch) =+        pure $ ClientHello ch{chExtensions = map zeroKeyShare $ chExtensions ch}+    zeroX25519 hs = pure hs+    zeroKeyShare ext@(ExtensionRaw eid bs)+        | eid == EID_KeyShare+        , Just (KeyShareClientHello kses) <- extensionDecode MsgTClientHello bs =+            toExtensionRaw $ KeyShareClientHello $ map zeroEntry kses+        | otherwise = ext+    -- The ML-KEM-768 encapsulation key (1184 bytes) is followed by the+    -- X25519 public key (32 bytes).+    zeroEntry (KeyShareEntry grp key)+        | grp == X25519MLKEM768 =+            KeyShareEntry grp $ B.take 1184 key <> B.replicate 32 0+    zeroEntry kse = kse++serverRejectedZeroX25519 :: TLSException -> Bool+serverRejectedZeroX25519 (HandshakeFailed (Error_Protocol msg alert)) =+    msg == "invalid client X25519MLKEM768 public key"+        && alert == IllegalParameter+serverRejectedZeroX25519 _ = False++post_handshake_auth :: CSP13 -> IO ()+post_handshake_auth (CSP13 (clientParam, serverParam)) = do+    cred <- generate (arbitraryClientCredential TLS13)+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = validateChain cred+                        }+                }+    if isCredentialDSA cred+        then runTLSFailure (clientParam', serverParam') hsClient hsServer+        else runTLSSuccess (clientParam', serverParam') hsClient hsServer+  where+    validateChain cred chain+        | chain == fst cred = return CertificateUsageAccept+        | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)+    hsClient ctx = do+        handshake ctx+        sendData ctx "request 1"+        recvDataAssert ctx "response 1"+        sendData ctx "request 2"+        recvDataAssert ctx "response 2"+    hsServer ctx = do+        handshake ctx+        recvDataAssert ctx "request 1"+        _ <- requestCertificate ctx -- single request+        sendData ctx "response 1"+        recvDataAssert ctx "request 2"+        _ <- requestCertificate ctx+        _ <- requestCertificate ctx -- two simultaneously+        sendData ctx "response 2"++-- | 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+-- receive buffer, so the bytes consumed for the record header would be lost and+-- the caller's next 'recvData' would decode part of a record body as a header.+--+-- Here the server's first write is one full-size record whose body is made to+-- arrive late, so the peek does hit its deadline with the header already+-- consumed.  Before the fix this failed with+-- @Error_Protocol "record exceeding maximum size" RecordOverflow@.+handshake13_client_auth_slow_record :: IO ()+handshake13_client_auth_slow_record = do+    (clientParam, serverParam) <- generate arbitraryPairParams13+    cred <- generate (arbitraryClientCredential TLS13)+    let clientParam' =+            clientParam+                { clientHooks =+                    (clientHooks clientParam)+                        { onCertificateRequest = \_ -> return $ Just cred+                        }+                }+        serverParam' =+            serverParam+                { serverWantClientCert = True+                , serverHooks =+                    (serverHooks serverParam)+                        { onClientCertificate = \_ -> return CertificateUsageAccept+                        }+                }+        payload = B.replicate 16384 65+    withPairContextWith (delayBigReads, id) (clientParam', serverParam') $+        \(cCtx, sCtx) ->+            concurrently_+                ( do+                    handshake sCtx+                    sendData sCtx $ L.fromStrict payload+                )+                ( do+                    handshake cCtx+                    recvData cCtx `shouldReturn` payload+                )+  where+    -- Only the body of the big record is held back; every handshake record is+    -- far smaller than this threshold and so arrives immediately.+    delayBigReads be =+        be+            { backendRecv = \n -> do+                when (n > 4096) $ threadDelay 300000+                backendRecv be n+            }++-- A protected record too short for the cipher cannot be deprotected, which+-- RFC 5246 Section 7.2.2 and RFC 8446 Section 5.2 answer with+-- bad_record_mac.  The client's first application data record is cut down+-- to a single byte of ciphertext on its way to the server.+short_record_bad_record_mac :: Version -> Cipher -> IO ()+short_record_bad_record_mac version cipher = do+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                ([cipher], [cipher])+    armed <- newIORef False+    let truncateRecord be =+            be+                { backendSend = \bs -> do+                    cut <- readIORef armed+                    if cut && B.length bs > 6 && B.head bs == 23+                        then do+                            writeIORef armed False+                            backendSend be $ B.take 3 bs <> B.pack [0, 1] <> B.take 1 (B.drop 5 bs)+                        else backendSend be bs+                }+    withPairContextWith (truncateRecord, id) (clientParam, serverParam) $+        \(cctx, sctx) ->+            concurrently_+                ( do+                    handshake sctx+                    recvData sctx `shouldThrow` serverRejectedShortRecord+                )+                ( do+                    handshake cctx+                    writeIORef armed True+                    sendData cctx "hello"+                    void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString))+                )++serverRejectedShortRecord :: TLSException -> Bool+serverRejectedShortRecord (Terminated _ _ (Error_Protocol _ BadRecordMac)) = True+serverRejectedShortRecord _ = False++-- The first handshake message a server receives must be a ClientHello; any+-- other is out of order and answered with unexpected_message (RFC 8446+-- Section 4), whatever its body would decode to.  The handshake type of the+-- client's first record is replaced on its way to the server.+server_first_message_unexpected :: Word8 -> IO ()+server_first_message_unexpected ty = do+    (clientParam, serverParam) <- generate arbitrary+    armed <- newIORef True+    let retype be =+            be+                { backendSend = \bs -> do+                    first <- atomicModifyIORef' armed (\a -> (False, a))+                    if first && B.length bs > 5 && B.head bs == 22+                        then backendSend be $ B.take 5 bs <> B.singleton ty <> B.drop 6 bs+                        else backendSend be bs+                }+    withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) ->+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+            (handshake cctx `shouldThrow` anyTLSException)++-- ChangeCipherSpec comes between complete handshake messages (RFC 5246+-- Section 7.1), and a server has no handshake state before its first+-- ClientHello (CVE-2004-0079).  The client's first record is split after+-- the given number of bytes of its body, and a ChangeCipherSpec record is+-- sent in between; with 0 it is sent before the whole ClientHello.+server_ccs_interleaved :: Int -> IO ()+server_ccs_interleaved n = do+    (clientParam, serverParam) <- generate arbitrary+    armed <- newIORef True+    let interleave be =+            be+                { backendSend = \bs -> do+                    first <- atomicModifyIORef' armed (\a -> (False, a))+                    if first && B.length bs > 5 + n && B.head bs == 22+                        then do+                            let (hdr, body) = B.splitAt 5 bs+                                (body1, body2) = B.splitAt n body+                                record b = B.take 3 hdr <> encodeWord16 (fromIntegral $ B.length b) <> b+                                ccs = B.pack [20, 3, 3, 0, 1, 1]+                            if n == 0+                                then backendSend be $ ccs <> bs+                                else backendSend be $ record body1 <> ccs <> record body2+                        else backendSend be bs+                }+    withPairContextWith (interleave, id) (clientParam, serverParam) $ \(cctx, sctx) ->+        concurrently_+            (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+            (handshake cctx `shouldThrow` anyTLSException)++-- An unknown record type is answered with unexpected_message (RFC 8446+-- Section 5).  The type of the client's first record is replaced; with a+-- length larger than what follows, as an SSLv2 ClientHello reads when taken+-- for a TLS record header, the server must answer from the header alone+-- rather than wait for a body that never comes.  A length of 0 keeps the+-- original one.+server_first_record_type_unexpected :: Word8 -> Word16 -> IO ()+server_first_record_type_unexpected ty len = do+    (clientParam, serverParam) <- generate arbitrary+    armed <- newIORef True+    let retype be =+            be+                { backendSend = \bs -> do+                    first <- atomicModifyIORef' armed (\a -> (False, a))+                    if first && B.length bs > 5 && B.head bs == 22+                        then do+                            let lenBytes+                                    | len == 0 = B.take 2 (B.drop 3 bs)+                                    | otherwise =+                                        B.pack [fromIntegral (len `div` 256), fromIntegral (len `mod` 256)]+                            backendSend be $+                                B.singleton ty <> B.take 2 (B.drop 1 bs) <> lenBytes <> B.drop 5 bs+                        else backendSend be bs+                }+    r <- timeout 5000000 $+        withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) ->+            concurrently_+                (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+                (handshake cctx `shouldThrow` anyTLSException)+    r `shouldSatisfy` isJust++-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with+-- other record types.  After the handshake the client sends, protected under+-- its application traffic secret, a record holding only the first two bytes+-- of a KeyUpdate and then a record of application data.  The server must not+-- deliver the data and must answer with unexpected_message.+handshake13_interleaved_app_data :: IO ()+handshake13_interleaved_app_data = do+    let cipher = cipher13_AES_128_GCM_SHA256+    (clientParam, serverParam) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([TLS13], [TLS13])+                ([cipher], [cipher])+    secretRef <- newIORef Nothing+    sendRef <- newIORef (\_ -> return ())+    let logKey line = case words line of+            ["CLIENT_TRAFFIC_SECRET_0", _, h] -> writeIORef secretRef (Just h)+            _ -> return ()+        clientParam' =+            clientParam+                { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey}+                }+        -- remember the raw sender so that records can be written by hand+        capture be =+            be+                { backendSend = \bs -> do+                    writeIORef sendRef (backendSend be)+                    backendSend be bs+                }+    withPairContextWith (capture, id) (clientParam', serverParam) $ \(cctx, sctx) ->+        concurrently_+            ( do+                handshake sctx+                r <- E.try (recvData sctx) :: IO (Either TLSException B.ByteString)+                case r of+                    Right d -> expectationFailure $ "server delivered " ++ show d+                    Left _ -> return ()+            )+            ( do+                handshake cctx+                Just h <- readIORef secretRef+                send <- readIORef sendRef+                let secret = BA.convert (unhex h) :: BA.ScrubbedBytes+                    key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString+                    iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString+                    -- the first two bytes of KeyUpdate(update_not_requested)+                    partialKeyUpdate = B.pack [24, 0]+                send $ protect13 key iv 0 22 partialKeyUpdate+                send $ protect13 key iv 1 23 "hello"+                recvData cctx `shouldThrow` peerSentUnexpected+            )+  where+    unhex [] = B.empty+    unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest)+    unhex _ = error "unhex"++-- A ChangeCipherSpec is the single byte 1; any other value is answered with+-- unexpected_message (RFC 8446 Section 5), and so is one carrying two of+-- them.  The client's ChangeCipherSpec record is made two bytes long.  The+-- groups are fixed so that a TLS 1.3 handshake goes through a+-- HelloRetryRequest -- after which the client sends its ChangeCipherSpec+-- before the second ClientHello -- or not, as the test asks.+malformed_ccs_unexpected :: Version -> Cipher -> [Group] -> [Group] -> IO ()+malformed_ccs_unexpected version cipher cgroups sgroups = do+    (clientParam0, serverParam0) <-+        generate $+            arbitraryPairParamsWithVersionsAndCiphers+                ([version], [version])+                ([cipher], [cipher])+    let clientParam =+            clientParam0+                { clientSupported = (clientSupported clientParam0){supportedGroups = cgroups}+                }+        serverParam =+            serverParam0+                { serverSupported =+                    (serverSupported serverParam0)+                        { supportedGroups = sgroups+                        , supportedGroupsTLS13 = [sgroups]+                        }+                }+    seen <- newIORef False+    let ccs = B.pack [20, 3, 3, 0, 1, 1]+        doubled = B.pack [20, 3, 3, 0, 2, 1, 1]+        double be =+            be+                { backendSend = \bs ->+                    if ccs `B.isPrefixOf` bs+                        then do+                            writeIORef seen True+                            backendSend be $ doubled <> B.drop 6 bs+                        else backendSend be bs+                }+    -- a TLS 1.3 server takes the client's ChangeCipherSpec and Finished in+    -- its first recvData, a TLS 1.2 one in handshake+    r <- timeout 10000000 $+        withPairContextWith (double, id) (clientParam, serverParam) $ \(cctx, sctx) ->+            concurrently_+                ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsUnexpected)+                ( void+                    (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+                )+    r `shouldSatisfy` isJust+    readIORef seen `shouldReturn` True++rejectedAsUnexpected :: TLSException -> Bool+rejectedAsUnexpected (HandshakeFailed (Error_Packet_unexpected _ _)) = True+rejectedAsUnexpected (Terminated _ _ (Error_Packet_unexpected _ _)) = True+rejectedAsUnexpected _ = False++-- An AES-128-GCM TLS 1.3 record: content and inner type, protected with the+-- record header as additional data and the sequence number in the nonce.+protect13 :: B.ByteString -> B.ByteString -> Word64 -> Word8 -> B.ByteString -> B.ByteString+protect13 key iv sqn innerType content = hdr <> ct <> BA.convert tag+  where+    len = B.length content + 1 + 16+    hdr = B.pack [23, 3, 3, fromIntegral (len `div` 256), fromIntegral (len `mod` 256)]+    sqnBytes = B.pack [fromIntegral (sqn `shiftR` (8 * i)) | i <- [7, 6 .. 0]]+    nonce = B.pack $ B.zipWith xor iv (B.replicate 4 0 <> sqnBytes)+    aes = throwCryptoError (cipherInit key) :: AES128+    aead = throwCryptoError (aeadInit AEAD_GCM aes nonce)+    (AuthTag tag, ct) = aeadSimpleEncrypt aead hdr (content <> B.singleton innerType) 16++peerSentUnexpected :: TLSException -> Bool+peerSentUnexpected (Terminated True _ (Error_Protocol _ UnexpectedMessage)) = True+peerSentUnexpected _ = False++serverRejectedUnexpectedFirst :: TLSException -> Bool+serverRejectedUnexpectedFirst (HandshakeFailed (Error_Packet_unexpected _ _)) = True+serverRejectedUnexpectedFirst _ = False  expectJust :: String -> Maybe a -> Expectation expectJust tag mx = case mx of
test/Run.hs view
@@ -16,6 +16,9 @@     runTLSFailure,     expectMaybe,     newPairContext,+    newPairContextWith,+    withPairContext,+    withPairContextWith,     withDataPipe,     byeBye, ) where@@ -156,6 +159,16 @@         handshake ctx         sendData ctx $ L.fromStrict earlyData         _ <- recvData ctx+        -- One more exchange, and this one the client starts.  Our Finished is+        -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop+        -- above is what puts it on the wire.  The server emits the+        -- NewSessionTicket when it reads that Finished, which is after it sent+        -- the echo -- so reading the echo is not enough to have seen the+        -- ticket, and neither is a byte the server sends straight after it.+        -- The server cannot answer this without having read past the Finished+        -- first, and records arrive in order.+        sendData ctx "x"+        recvDataAssert ctx "x"         bye ctx         mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx         expectMaybe "C: mode should be Just" mode mmode@@ -165,6 +178,8 @@         chunks <- replicateM (length ls) $ recvData ctx         (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData)         sendData ctx $ L.fromStrict earlyData+        recvDataAssert ctx "x"+        sendData ctx "x"         bye ctx         mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx         expectMaybe "S: mode should be Just" mode mmode@@ -187,6 +202,16 @@         handshake ctx         sendData ctx $ L.fromStrict earlyData         _ <- recvData ctx+        -- One more exchange, and this one the client starts.  Our Finished is+        -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop+        -- above is what puts it on the wire.  The server emits the+        -- NewSessionTicket when it reads that Finished, which is after it sent+        -- the echo -- so reading the echo is not enough to have seen the+        -- ticket, and neither is a byte the server sends straight after it.+        -- The server cannot answer this without having read past the Finished+        -- first, and records arrive in order.+        sendData ctx "x"+        recvDataAssert ctx "x"         bye ctx         minfo <- contextGetInformation ctx         let mmode = minfo >>= infoTLS13HandshakeMode@@ -199,6 +224,8 @@         chunks <- replicateM (length ls) $ recvData ctx         (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData)         sendData ctx $ L.fromStrict earlyData+        recvDataAssert ctx "x"+        sendData ctx "x"         bye ctx         mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx         expectMaybe "S: mode should be Just" mode mmode@@ -295,11 +322,15 @@         hsClient ctx         d <- readChan queue         sendData ctx (L.fromChunks [d])+        -- The server writes after any TLS 1.3 NewSessionTicket, so waiting for+        -- this byte ensures the client session manager received the ticket.+        recvDataAssert ctx "x"         checkCtxFinished ctx         bye ctx     tlsServer ctx queue = do         hsServer ctx         d <- recvData ctx+        sendData ctx "x"         writeChan queue [d]         checkCtxFinished ctx         bye ctx@@ -326,16 +357,32 @@  withPairContext     :: (ClientParams, ServerParams) -> ((Context, Context) -> IO ()) -> IO ()-withPairContext params body =+withPairContext = withPairContextWith (id, id)++withPairContextWith+    :: (Backend -> Backend, Backend -> Backend)+    -> (ClientParams, ServerParams)+    -> ((Context, Context) -> IO ())+    -> IO ()+withPairContextWith wrapBackends params body =     E.bracket-        (newPairContext params)+        (newPairContextWith wrapBackends params)         (\((t1, t2), _) -> killThread t1 >> killThread t2)         (\(_, ctxs) -> body ctxs)  newPairContext     :: (ClientParams, ServerParams)     -> IO ((ThreadId, ThreadId), (Context, Context))-newPairContext (cParams, sParams) = do+newPairContext = newPairContextWith (id, id)++-- | 'newPairContext' with a hook on each side's 'Backend' -- client first, as+-- with the parameters -- so that a test can control how bytes arrive (delay+-- them, split them).  Pass 'id' for a side to leave it alone.+newPairContextWith+    :: (Backend -> Backend, Backend -> Backend)+    -> (ClientParams, ServerParams)+    -> IO ((ThreadId, ThreadId), (Context, Context))+newPairContextWith (wrapCBackend, wrapSBackend) (cParams, sParams) = do     pipe <- newPipe     tids <- runPipe pipe     let noFlush = return ()@@ -343,8 +390,8 @@      let cBackend = Backend noFlush noClose (writePipeC pipe) (readPipeC pipe)     let sBackend = Backend noFlush noClose (writePipeS pipe) (readPipeS pipe)-    cCtx' <- contextNew cBackend cParams-    sCtx' <- contextNew sBackend sParams+    cCtx' <- contextNew (wrapCBackend cBackend) cParams+    sCtx' <- contextNew (wrapSBackend sBackend) sParams      contextHookSetLogging cCtx' (logging "client: ")     contextHookSetLogging sCtx' (logging "server: ")
+ test/SecretSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module SecretSpec where++import Crypto.Debug (debugShow)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Data.List (isInfixOf)+import Network.TLS (Version (TLS13))+import Network.TLS.Extra.Cipher (ciphersuite_default)+import Network.TLS.Internal (SessionData (..))+import Network.TLS.QUIC+import Test.Hspec++-- | The traffic secrets reach a QUIC implementation through+-- 'quicInstallKeys', so a trace of what it is handed must not write them to a+-- log.  'debugShow' is how a debugging session asks for them on purpose.+spec :: Spec+spec = do+    describe "Show of the QUIC secret types" $ do+        it "does not print an early traffic secret" $+            check $+                EarlySecretInfo cipher clientSecret+        it "does not print the handshake traffic secrets" $+            check $+                HandshakeSecretInfo cipher (clientSecret, serverSecret)+        it "does not print the application traffic secrets" $+            check $+                ApplicationSecretInfo (clientSecret, serverSecret)+    describe "Show of a resumable session" $+        it "does not print the session secret" $ do+            let shown = show sessionData+            show (B.replicate 32 0xa5) `isInfixOf` shown `shouldBe` False+            "<secret>" `isInfixOf` shown `shouldBe` True+            show (B.replicate 32 0xa5)+                `isInfixOf` debugShow sessionData+                `shouldBe` True+  where+    sessionData =+        SessionData+            { sessionVersion = TLS13+            , sessionCipher = 0x1301+            , sessionCompression = 0+            , sessionClientSNI = Just "example.com"+            , sessionSecret = B.replicate 32 0xa5+            , sessionGroup = Nothing+            , sessionTicketInfo = Nothing+            , sessionALPN = Nothing+            , sessionMaxEarlyDataSize = 0+            , sessionFlags = []+            }+    cipher = case ciphersuite_default of+        c : _ -> c+        [] -> error "ciphersuite_default is empty"+    clientSecret = ClientTrafficSecret $ BA.convert $ B.replicate 32 0xa5+    serverSecret = ServerTrafficSecret $ BA.convert $ B.replicate 32 0x5a+    hexOf w = concat $ replicate 32 w+    check x = do+        let shown = show x+        hexOf "a5" `isInfixOf` shown `shouldBe` False+        hexOf "5a" `isInfixOf` shown `shouldBe` False+        "<secret>" `isInfixOf` shown `shouldBe` True+        hexOf "a5" `isInfixOf` debugShow x `shouldBe` True
tls.cabal view
@@ -1,6 +1,6 @@-cabal-version:      >=1.10+cabal-version:      2.0 name:               tls-version:            2.1.14+version:            2.4.9 license:            BSD3 license-file:       LICENSE copyright:          Vincent Hanquez <vincent@snarc.org>@@ -34,6 +34,7 @@         Network.TLS.Internal         Network.TLS.Extra         Network.TLS.Extra.Cipher+        Network.TLS.Extra.CipherCBC         Network.TLS.Extra.FFDHE         Network.TLS.QUIC @@ -113,69 +114,32 @@         Network.TLS.Wire         Network.TLS.X509 +    default-language:   Haskell2010     default-extensions: Strict StrictData-    default-language: Haskell2010-    ghc-options:      -Wall+    ghc-options:        -Wall     build-depends:         base >=4.9 && <5,-        asn1-encoding >= 0.9 && < 0.10,-        asn1-types >= 0.3 && < 0.4,         base16-bytestring,-        bytestring >= 0.10 && < 0.13,-        cereal >= 0.5.3 && < 0.6,-        crypton >= 0.34,-        crypton-x509 >= 1.7 && < 1.8,-        crypton-x509-store >= 1.6 && < 1.7,-        crypton-x509-validation >= 1.6.13 && < 1.7,+        bytestring >=0.10 && <0.13,+        cereal >=0.5.3 && <0.6,+        crypton >=2.1.1 && <2.2,+        crypton-asn1-encoding >= 0.10.0 && < 0.11,+        crypton-asn1-types >= 0.4.1 && < 0.5,+        crypton-x509 >=1.9 && <1.10,+        crypton-x509-store >=1.9 && <1.10,+        crypton-x509-validation >=1.9 && <1.10,         data-default,         ech-config,-        hpke,-        memory >= 0.18 && < 0.19,-        mtl >= 2.2 && < 2.4,-        network >= 3.1,-        random >= 1.2 && < 1.4,-        serialise >= 0.2 && < 0.3,-        transformers >= 0.5 && < 0.7,-        unix-time >= 0.4.11 && < 0.5,-        zlib >= 0.7 && < 0.8--test-suite spec-    type:               exitcode-stdio-1.0-    main-is:            Spec.hs-    build-tool-depends: hspec-discover:hspec-discover-    hs-source-dirs:     test-    other-modules:-        API-        Arbitrary-        Certificate-        CiphersSpec-        ECHSpec-        EncodeSpec-        HandshakeSpec-        PipeChan-        PubKey-        Run-        Session-        ThreadSpec--    default-extensions: Strict StrictData-    default-language:   Haskell2010-    ghc-options:        -Wall -threaded -rtsopts-    build-depends:-        base >=4.9 && <5,-        QuickCheck,-        asn1-types,-        async,-        base64-bytestring,-        bytestring,-        crypton,-        crypton-x509,-        crypton-x509-validation,-        ech-config,-        hourglass,-        hspec,-        serialise,-        tls+        hpke >=0.1.0 && <0.3,+        mlkem >= 0.2.0 && <0.3,+        mtl >=2.2 && <2.4,+        network >=3.1,+        ram >=0.22.0 && <0.23,+        random >=1.2 && <1.4,+        serialise >=0.2 && <0.3,+        transformers >=0.5 && <0.7,+        unix-time >=0.4.11 && <0.6,+        zlib >=0.7 && <0.8  executable tls-server     main-is:            tls-server.hs@@ -190,8 +154,8 @@     ghc-options:        -Wall -threaded -rtsopts     build-depends:         base >=4.9 && <5,-        bytestring,         base16-bytestring,+        bytestring,         containers,         crypton,         crypton-x509-store,@@ -226,7 +190,7 @@         crypton-x509-system,         ech-config,         network,-        network-run >= 0.5,+        network-run >=0.6.0 && < 0.7,         tls      if flag(devel)@@ -234,9 +198,11 @@     else         buildable: False -benchmark tls-bench-    main-is: Benchmarks.hs-    type: exitcode-stdio-1.0+test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Spec.hs+    build-tool-depends: hspec-discover:hspec-discover+    hs-source-dirs:     test     other-modules:         API         Arbitrary@@ -248,31 +214,70 @@         PipeChan         PubKey         Run+        SecretSpec         Session         ThreadSpec-    hs-source-dirs:-        Benchmarks-        test+     default-language:   Haskell2010-    ghc-options: -Wall+    default-extensions: Strict StrictData+    ghc-options:        -Wall -threaded -rtsopts     build-depends:         base >=4.9 && <5,+        QuickCheck,+        async,+        base64-bytestring,         bytestring,+        crypton,+        crypton-asn1-types,+        crypton-x509,+        crypton-x509-validation,+        ech-config,+        hspec,+        ram,+        serialise,+        time-hourglass,+        tls,+        zlib++benchmark tls-bench+    type:             exitcode-stdio-1.0+    main-is:          Benchmarks.hs+    hs-source-dirs:   Benchmarks test+    other-modules:+        API+        Arbitrary+        Certificate+        CiphersSpec+        ECHSpec+        EncodeSpec+        HandshakeSpec+        PipeChan+        PubKey+        Run+        Session+        ThreadSpec++    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.9 && <5,+        QuickCheck,+        async,         base64-bytestring,+        bytestring,         containers,-        async,-        data-default,-        hourglass,         crypton,+        crypton-asn1-types,         crypton-x509,         crypton-x509-store,         crypton-x509-validation,+        data-default,         ech-config,+        hspec,         network,         network-run,-        tls,-        asn1-types,-        tasty-bench,-        QuickCheck,+        ram,         serialise,-        hspec+        tasty-bench,+        time-hourglass,+        tls
util/Common.hs view
@@ -36,19 +36,27 @@     , ("ffdhe8192", ffdhe8192)     ] +{- FOURMOLU_DISABLE -} namedGroups :: [(String, Group)] namedGroups =-    [ ("ffdhe2048", FFDHE2048)-    , ("ffdhe3072", FFDHE3072)-    , ("ffdhe4096", FFDHE4096)-    , ("ffdhe6144", FFDHE6144)-    , ("ffdhe8192", FFDHE8192)-    , ("p256", P256)-    , ("p384", P384)-    , ("p521", P521)-    , ("x25519", X25519)-    , ("x448", X448)+    [ ("ffdhe2048",      FFDHE2048)+    , ("ffdhe3072",      FFDHE3072)+    , ("ffdhe4096",      FFDHE4096)+    , ("ffdhe6144",      FFDHE6144)+    , ("ffdhe8192",      FFDHE8192)+    , ("p256",           P256)+    , ("p384",           P384)+    , ("p521",           P521)+    , ("x25519",         X25519)+    , ("x448",           X448)+    , ("mlkem512",       MLKEM512)+    , ("mlkem768",       MLKEM768)+    , ("mlkem1024",      MLKEM1024)+    , ("x25519mlkem768", X25519MLKEM768)+    , ("p256mlkem768",   P256MLKEM768)+    , ("p384mlkem1024",  P384MLKEM1024)     ]+{- FOURMOLU_ENABLE -}  readNumber :: (Num a, Read a) => String -> Maybe a readNumber s@@ -103,7 +111,7 @@     minfo <- contextGetInformation ctx     case minfo of         Nothing -> do-            putStrLn "Erro: information cannot be obtained"+            putStrLn "Error: information cannot be obtained"             exitFailure         Just info -> return info
util/Server.hs view
@@ -28,15 +28,18 @@   where     body = "<html><<body>Hello world!</body></html>" +-- An HTTP request is answered with HTML, anything else is echoed.+-- tlsfuzzer's test-lengths.py sends "A..A\n", or just "\n", and expects+-- it back. server :: Context -> Bool -> IO () server ctx showRequest = do     bs <- recvData ctx     case C8.uncons bs of         Nothing -> return ()-        Just ('A', _) -> do+        Just ('G', _) -> handleHTML ctx showRequest bs+        Just _ -> do             sendData ctx $ CL8.fromStrict bs             echo ctx-        Just _ -> handleHTML ctx showRequest bs  echo :: Context -> IO () echo ctx = loop
util/tls-server.hs view
@@ -4,12 +4,16 @@  module Main where +import qualified Control.Exception as E import Data.IORef import qualified Data.Map.Strict as M import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS import Network.TLS.ECH.Config+import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC+import Network.TLS.Extra.FFDHE import Network.TLS.Internal import System.Console.GetOpt import System.Environment (getArgs)@@ -27,12 +31,14 @@     , optShow :: Bool     , optKeyLogFile :: Maybe FilePath     , optTrustedAnchor :: Maybe FilePath-    , optGroups :: [Group]+    , optGroups :: Maybe [Group]     , optCertFile :: FilePath     , optKeyFile :: FilePath     , optECHConfigFile :: Maybe FilePath     , optECHKeyFile :: Maybe FilePath     , optTraceKey :: Bool+    , optUseWeakCiphers :: Bool+    , optServerName :: Maybe HostName     }     deriving (Show) @@ -44,13 +50,14 @@         , optShow = False         , optKeyLogFile = Nothing         , optTrustedAnchor = Nothing-        , -- excluding FFDHE8192 for retry-          optGroups = FFDHE8192 `delete` supportedGroups defaultSupported+        , optGroups = Nothing         , optCertFile = "servercert.pem"         , optKeyFile = "serverkey.pem"         , optECHConfigFile = Nothing         , optECHKeyFile = Nothing         , optTraceKey = False+        , optUseWeakCiphers = False+        , optServerName = Nothing         }  options :: [OptDescr (Options -> Options)]@@ -78,7 +85,7 @@     , Option         ['g']         ["groups"]-        (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+        (ReqArg (\gs o -> o{optGroups = Just $ readGroups gs}) "<groups>")         "groups for key exchange"     , Option         ['c']@@ -110,6 +117,16 @@         ["trace-key"]         (NoArg (\o -> o{optTraceKey = True}))         "Trace transcript hash"+    , Option+        []+        ["use-weak-ciphers"]+        (NoArg (\o -> o{optUseWeakCiphers = True}))+        "accept deprecated ciphers and relax checks (for tlsfuzzer)"+    , Option+        []+        ["server-name"]+        (ReqArg (\n o -> o{optServerName = Just n}) "<name>")+        "refuse other names in SNI with unrecognized_name"     ]  usage :: String@@ -135,7 +152,12 @@     (host, port) <- case ips of         [h, p] -> return (h, p)         _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"-    when (null optGroups) $ do+    let groups = fromMaybe defaultGroups optGroups+        defaultGroups+            | optUseWeakCiphers = supportedGroups defaultSupported+            -- excluding FFDHE8192 for retry+            | otherwise = FFDHE8192 `delete` supportedGroups defaultSupported+    when (null groups) $ do         putStrLn "Error: unsupported groups"         exitFailure     smgr <- newSessionManager@@ -169,7 +191,8 @@         let sparams =                 getServerParams                     creds-                    optGroups+                    optUseWeakCiphers+                    groups                     smgr                     keyLog                     optClientAuth@@ -177,6 +200,7 @@                     ech                     printError                     traceKey+                    optServerName         ctx <- contextNew sock sparams         when optDebugLog $             contextHookSetLogging@@ -196,6 +220,7 @@  getServerParams     :: Credentials+    -> Bool     -> [Group]     -> SessionManager     -> (String -> IO ())@@ -204,8 +229,9 @@     -> ([(Word8, ByteString)], ECHConfigList)     -> (String -> IO ())     -> (String -> IO ())+    -> Maybe HostName     -> ServerParams-getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey =+getServerParams creds weak groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname =     defaultParamsServer         { serverSupported = supported         , serverShared = shared@@ -214,6 +240,7 @@         , serverEarlyDataSize = 2048         , serverWantClientCert = clientAuth         , serverECHKey = ekey+        , serverDHEParams = if weak then Just ffdhe2048 else Nothing         }   where     shared =@@ -231,15 +258,26 @@             }     supported =         defaultSupported-            { supportedGroups = groups+            { supportedCiphers = ciphers+            , supportedGroups = groups+            , supportedExtendedMainSecret =+                if weak then AllowEMS else supportedExtendedMainSecret defaultSupported+            , supportedClientInitiatedRenegotiation =+                weak || supportedClientInitiatedRenegotiation defaultSupported             }+    ciphers+        | weak = ciphersuite_default ++ ciphersForFuzzer+        | otherwise = ciphersuite_default     hooks =         defaultServerHooks-            { onALPNClientSuggest = Just chooseALPN+            { onALPNClientSuggest = Just $ chooseALPN weak             , onClientCertificate = case mstore of                 Nothing -> onClientCertificate defaultServerHooks-                Just _ ->-                    validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+                Just _+                    | weak -> acceptEmptyCertificate+                    | otherwise ->+                        validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+            , onServerNameIndication = checkServerName mname             }     debug =         defaultDebugParams@@ -247,12 +285,122 @@             , debugError = printError             , debugTraceKey = traceKey             }+    acceptEmptyCertificate cc+        | isNullCertificateChain cc = return CertificateUsageAccept+        | otherwise =+            validateClientCertificate+                (sharedCAStore shared)+                (sharedValidationCache shared)+                cc -chooseALPN :: [ByteString] -> IO ByteString-chooseALPN protos-    | "http/1.1" `elem` protos = return "http/1.1"-    | otherwise = return ""+----------------------------------------------------------------+-- Deprecated ciphers, accepted only with --use-weak-ciphers.+-- tlsfuzzer uses them in its TLS 1.2 tests. +ciphersForFuzzer :: [Cipher]+ciphersForFuzzer =+    [ cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA+    , cipher_DHE_RSA_WITH_AES_128_CBC_SHA+    , cipher_RSA_WITH_AES_256_CBC_SHA+    , cipher_RSA_WITH_AES_128_CBC_SHA+    , cipher_RSA_WITH_AES_128_CBC_SHA256+    , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+    , cipher_RSA_WITH_AES_128_GCM_SHA256+    , cipher_RSA_WITH_AES_256_GCM_SHA384+    , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+    , cipher13_AES_128_CCM_8_SHA256+    ]+        ++ ciphersuite_pfs_sha2_cbc++-- CBC with HMAC-SHA1, derived from the SHA-2 ones in CipherCBC.+cipher_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_RSA_WITH_AES_128_CBC_SHA =+    cipher_DHE_RSA_AES128_SHA256+        { cipherID = 0x002F+        , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA"+        , cipherHash = SHA1+        , cipherPRFHash = Nothing+        , cipherKeyExchange = CipherKeyExchange_RSA+        , cipherMinVer = Just SSL3+        }++cipher_RSA_WITH_AES_256_CBC_SHA :: Cipher+cipher_RSA_WITH_AES_256_CBC_SHA =+    cipher_DHE_RSA_AES256_SHA256+        { cipherID = 0x0035+        , cipherName = "TLS_RSA_WITH_AES_256_CBC_SHA"+        , cipherHash = SHA1+        , cipherPRFHash = Nothing+        , cipherKeyExchange = CipherKeyExchange_RSA+        , cipherMinVer = Just SSL3+        }++-- tlsfuzzer's test-atypical-padding.py and test-lengths.py use this one+-- for an HMAC-SHA256 record.+cipher_RSA_WITH_AES_128_CBC_SHA256 :: Cipher+cipher_RSA_WITH_AES_128_CBC_SHA256 =+    cipher_DHE_RSA_AES128_SHA256+        { cipherID = 0x003C+        , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA256"+        , cipherKeyExchange = CipherKeyExchange_RSA+        }++cipher_DHE_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_DHE_RSA_WITH_AES_128_CBC_SHA =+    cipher_RSA_WITH_AES_128_CBC_SHA+        { cipherID = 0x0033+        , cipherName = "TLS_DHE_RSA_WITH_AES_128_CBC_SHA"+        , cipherKeyExchange = CipherKeyExchange_DHE_RSA+        , cipherMinVer = Nothing+        }++cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA =+    cipher_RSA_WITH_AES_128_CBC_SHA+        { cipherID = 0xC013+        , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA"+        , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+        , cipherMinVer = Just TLS10+        }++-- AES-GCM with RSA key exchange, derived from the DHE ones.+cipher_RSA_WITH_AES_128_GCM_SHA256 :: Cipher+cipher_RSA_WITH_AES_128_GCM_SHA256 =+    cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+        { cipherID = 0x009C+        , cipherName = "TLS_RSA_WITH_AES_128_GCM_SHA256"+        , cipherKeyExchange = CipherKeyExchange_RSA+        }++cipher_RSA_WITH_AES_256_GCM_SHA384 :: Cipher+cipher_RSA_WITH_AES_256_GCM_SHA384 =+    cipher_DHE_RSA_WITH_AES_256_GCM_SHA384+        { cipherID = 0x009D+        , cipherName = "TLS_RSA_WITH_AES_256_GCM_SHA384"+        , cipherKeyExchange = CipherKeyExchange_RSA+        }++-- Only HTTP/1.1 is spoken.  With --use-weak-ciphers, the names+-- tlsfuzzer's test-alpn-negotiation.py switches to on renegotiation and+-- resumption are accepted too, in the client's order.+chooseALPN :: Bool -> [ByteString] -> IO ByteString+chooseALPN weak protos = return $ fromMaybe "" $ find (`elem` known) protos+  where+    known+        | weak = ["http/1.1", "h2", "http/2"]+        | otherwise = ["http/1.1"]++-- RFC 6066 Section 3: a server that does not recognize the name may+-- abort with a fatal unrecognized_name, a warning one being NOT+-- RECOMMENDED.+checkServerName :: Maybe HostName -> Maybe HostName -> IO Credentials+checkServerName (Just name) (Just sni)+    | sni /= name =+        E.throwIO $+            Uncontextualized $+                Error_Protocol ("unrecognized name: " ++ sni) UnrecognizedName+checkServerName _ _ = return mempty+ newSessionManager :: IO SessionManager newSessionManager = do     ref <- newIORef M.empty@@ -262,9 +410,11 @@                 M.lookup key <$> readIORef ref             , sessionResumeOnlyOnce = \key -> do                 M.lookup key <$> readIORef ref-            , sessionEstablish = \key val -> do-                atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)+            , -- The session ID doubles as the ticket, so the table+              -- serves resumption by either.+              sessionEstablish = \key val -> do+                atomicModifyIORef' ref $ \m -> (M.insert key val m, Just key)             , sessionInvalidate = \key -> do                 atomicModifyIORef' ref $ \m -> (M.delete key m, ())-            , sessionUseTicket = False+            , sessionUseTicket = True             }