{-# LANGUAGE OverloadedStrings #-}

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"

expectJust :: String -> Maybe a -> Expectation
expectJust tag mx = case mx of
    Nothing -> expectationFailure tag
    Just _ -> return ()