    {-# LANGUAGE OverloadedStrings #-}
    -- |
    -- Module      : Network.TLS.Handshake.Server
    -- License     : BSD-style
    -- Maintainer  : Vincent Hanquez <vincent@snarc.org>
    -- Stability   : experimental
    -- Portability : unknown
    --
    module Network.TLS.Handshake.Server
        ( handshakeServer
        , handshakeServerWith
        , requestCertificateServer
        , postHandshakeAuthServerWith
        ) where

    import Network.TLS.Parameters
    import Network.TLS.Imports
    import Network.TLS.Context.Internal
    import Network.TLS.Session
    import Network.TLS.Struct
    import Network.TLS.Struct13
    import Network.TLS.Cipher
    import Network.TLS.Compression
    import Network.TLS.Credentials
    import Network.TLS.Crypto
    import Network.TLS.Extension
    import Network.TLS.Util (bytesEq, catchException, fromJust)
    import Network.TLS.IO
    import Network.TLS.Types
    import Network.TLS.State
    import Network.TLS.Handshake.Control
    import Network.TLS.Handshake.State
    import Network.TLS.Handshake.Process
    import Network.TLS.Handshake.Key
    import Network.TLS.Handshake.Random
    import Network.TLS.Measurement
    import qualified Data.ByteString as B
    import Data.X509 (ExtKeyUsageFlag(..))

    import Control.Monad.State.Strict
    import Control.Exception (bracket)

    import Network.TLS.Handshake.Signature
    import Network.TLS.Handshake.Common
    import Network.TLS.Handshake.Certificate
    import Network.TLS.X509
    import Network.TLS.Handshake.State13
    import Network.TLS.Handshake.Common13

    -- Put the server context in handshake mode.
    --
    -- Expect to receive as first packet a client hello handshake message
    --
    -- This is just a helper to pop the next message from the recv layer,
    -- and call handshakeServerWith.
    handshakeServer :: ServerParams -> Context -> IO ()
    handshakeServer :: ServerParams -> Context -> IO ()
    handshakeServer ServerParams
    sparams Context
    ctx = IO () -> IO ()
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
        [Handshake]
    hss <- Context -> IO [Handshake]
    recvPacketHandshake Context
    ctx
        case [Handshake]
    hss of
            [Handshake
    ch] -> ServerParams -> Context -> Handshake -> IO ()
    handshakeServerWith ServerParams
    sparams Context
    ctx Handshake
    ch
            [Handshake]
    _    -> String -> Maybe String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected ([Handshake] -> String
    forall a. Show a => a -> String
    show [Handshake]
    hss) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "client hello")

    -- | 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.
    --
    -- When the function returns, a new handshake has been succesfully negociated.
    -- On any error, a HandshakeFailed exception is raised.
    --
    -- handshake protocol (<- receiving, -> sending, [] optional):
    --    (no session)           (session resumption)
    --      <- client hello       <- client hello
    --      -> server hello       -> server hello
    --      -> [certificate]
    --      -> [server key xchg]
    --      -> [cert request]
    --      -> hello done
    --      <- [certificate]
    --      <- client key xchg
    --      <- [cert verify]
    --      <- change cipher      -> change cipher
    --      <- finish             -> finish
    --      -> change cipher      <- change cipher
    --      -> finish             <- finish
    --
    handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
    handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
    handshakeServerWith ServerParams
    sparams Context
    ctx clientHello :: Handshake
    clientHello@(ClientHello Version
    legacyVersion ClientRandom
    _ Session
    clientSession [ExtensionID]
    ciphers [CompressionID]
    compressions [ExtensionRaw]
    exts Maybe ByteString
    _) = do
        Established
    established <- Context -> IO Established
    ctxEstablished Context
    ctx
        -- renego is not allowed in TLS 1.3
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Established
    established Established -> Established -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Established
    NotEstablished) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            Version
    ver <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (Version -> TLSSt Version
    getVersionWithDefault Version
    TLS10)
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Version
    ver Version -> Version -> Bool
    forall a. Eq a => a -> a -> Bool
    == Version
    TLS13) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "renegotiation is not allowed in TLS 1.3", Bool
    True, AlertDescription
    UnexpectedMessage)
        -- rejecting client initiated renegotiation to prevent DOS.
        Bool
    eof <- Context -> IO Bool
    ctxEOF Context
    ctx
        let renegotiation :: Bool
    renegotiation = Established
    established Established -> Established -> Bool
    forall a. Eq a => a -> a -> Bool
    == Established
    Established Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    eof
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Bool
    renegotiation Bool -> Bool -> Bool
    && Bool -> Bool
    not (Supported -> Bool
    supportedClientInitiatedRenegotiation (Supported -> Bool) -> Supported -> Bool
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx)) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "renegotiation is not allowed", Bool
    False, AlertDescription
    NoRenegotiation)
        -- check if policy allow this new handshake to happens
        Bool
    handshakeAuthorized <- Context -> (Measurement -> IO Bool) -> IO Bool
    forall a. Context -> (Measurement -> IO a) -> IO a
    withMeasure Context
    ctx (ServerHooks -> Measurement -> IO Bool
    onNewHandshake (ServerHooks -> Measurement -> IO Bool)
    -> ServerHooks -> Measurement -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams)
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless Bool
    handshakeAuthorized (TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String -> TLSError
    Error_HandshakePolicy String
    "server: handshake denied")
        Context -> (Measurement -> Measurement) -> IO ()
    updateMeasure Context
    ctx Measurement -> Measurement
    incrementNbHandshakes

        -- Handle Client hello
        Context -> Handshake -> IO ()
    processHandshake Context
    ctx Handshake
    clientHello

        -- rejecting SSL2. RFC 6176
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Version
    legacyVersion Version -> Version -> Bool
    forall a. Eq a => a -> a -> Bool
    == Version
    SSL2) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "SSL 2.0 is not supported", Bool
    True, AlertDescription
    ProtocolVersion)
        -- rejecting SSL3. RFC 7568
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Version
    legacyVersion Version -> Version -> Bool
    forall a. Eq a => a -> a -> Bool
    == Version
    SSL3) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "SSL 3.0 is not supported", Bool
    True, AlertDescription
    ProtocolVersion)

        -- Fallback SCSV: RFC7507
        -- TLS_FALLBACK_SCSV: {0x56, 0x00}
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Supported -> Bool
    supportedFallbackScsv (Context -> Supported
    ctxSupported Context
    ctx) Bool -> Bool -> Bool
    &&
              (ExtensionID
    0x5600 ExtensionID -> [ExtensionID] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ExtensionID]
    ciphers) Bool -> Bool -> Bool
    &&
              Version
    legacyVersion Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < Version
    TLS12) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "fallback is not allowed", Bool
    True, AlertDescription
    InappropriateFallback)
        -- choosing TLS version
        let clientVersions :: [Version]
    clientVersions = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_SupportedVersions [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe SupportedVersions)
    -> Maybe SupportedVersions
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe SupportedVersions
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
                Just (SupportedVersionsClientHello [Version]
    vers) -> [Version]
    vers -- fixme: vers == []
                Maybe SupportedVersions
    _                                        -> []
            clientVersion :: Version
    clientVersion = Version -> Version -> Version
    forall a. Ord a => a -> a -> a
    min Version
    TLS12 Version
    legacyVersion
            serverVersions :: [Version]
    serverVersions
                | Bool
    renegotiation = (Version -> Bool) -> [Version] -> [Version]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < Version
    TLS13) (Supported -> [Version]
    supportedVersions (Supported -> [Version]) -> Supported -> [Version]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx)
                | Bool
    otherwise     = Supported -> [Version]
    supportedVersions (Supported -> [Version]) -> Supported -> [Version]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx
            mVersion :: Maybe Version
    mVersion = DebugParams -> Maybe Version
    debugVersionForced (DebugParams -> Maybe Version) -> DebugParams -> Maybe Version
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> DebugParams
    serverDebug ServerParams
    sparams
        Version
    chosenVersion <- case Maybe Version
    mVersion of
          Just Version
    cver -> Version -> IO Version
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Version
    cver
          Maybe Version
    Nothing   ->
            if (Version
    TLS13 Version -> [Version] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Version]
    serverVersions) Bool -> Bool -> Bool
    && [Version]
    clientVersions [Version] -> [Version] -> Bool
    forall a. Eq a => a -> a -> Bool
    /= [] then case [Version] -> [Version] -> Maybe Version
    findHighestVersionFrom13 [Version]
    clientVersions [Version]
    serverVersions of
                      Maybe Version
    Nothing -> TLSError -> IO Version
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO Version) -> TLSError -> IO Version
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "client versions " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [Version] -> String
    forall a. Show a => a -> String
    show [Version]
    clientVersions String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " is not supported", Bool
    True, AlertDescription
    ProtocolVersion)
                      Just Version
    v  -> Version -> IO Version
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Version
    v
               else case Version -> [Version] -> Maybe Version
    findHighestVersionFrom Version
    clientVersion [Version]
    serverVersions of
                      Maybe Version
    Nothing -> TLSError -> IO Version
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO Version) -> TLSError -> IO Version
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "client version " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Version -> String
    forall a. Show a => a -> String
    show Version
    clientVersion String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " is not supported", Bool
    True, AlertDescription
    ProtocolVersion)
                      Just Version
    v  -> Version -> IO Version
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Version
    v

        -- SNI (Server Name Indication)
        let serverName :: Maybe String
    serverName = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_ServerName [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe ServerName) -> Maybe ServerName
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe ServerName
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
                Just (ServerName [ServerNameType]
    ns) -> [String] -> Maybe String
    forall a. [a] -> Maybe a
    listToMaybe ((ServerNameType -> Maybe String) -> [ServerNameType] -> [String]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe ServerNameType -> Maybe String
    toHostName [ServerNameType]
    ns)
                    where toHostName :: ServerNameType -> Maybe String
    toHostName (ServerNameHostName String
    hostName) = String -> Maybe String
    forall a. a -> Maybe a
    Just String
    hostName
                          toHostName (ServerNameOther (CompressionID, ByteString)
    _)           = Maybe String
    forall a. Maybe a
    Nothing
                Maybe ServerName
    _                    -> Maybe String
    forall a. Maybe a
    Nothing
        IO () -> (String -> IO ()) -> Maybe String -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) (Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> (String -> TLSSt ()) -> String -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> TLSSt ()
    setClientSNI) Maybe String
    serverName

        -- TLS version dependent
        if Version
    chosenVersion Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Version
    TLS12 then
            ServerParams
    -> Context
    -> Version
    -> [ExtensionRaw]
    -> [ExtensionID]
    -> Maybe String
    -> Version
    -> [CompressionID]
    -> Session
    -> IO ()
    handshakeServerWithTLS12 ServerParams
    sparams Context
    ctx Version
    chosenVersion [ExtensionRaw]
    exts [ExtensionID]
    ciphers Maybe String
    serverName Version
    clientVersion [CompressionID]
    compressions Session
    clientSession
          else do
            (CompressionID -> IO ()) -> [CompressionID] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ CompressionID -> IO ()
    forall (m :: * -> *). MonadIO m => CompressionID -> m ()
    ensureNullCompression [CompressionID]
    compressions
            -- fixme: we should check if the client random is the same as
            -- that in the first client hello in the case of hello retry.
            ServerParams
    -> Context
    -> Version
    -> [ExtensionRaw]
    -> [ExtensionID]
    -> Maybe String
    -> Session
    -> IO ()
    handshakeServerWithTLS13 ServerParams
    sparams Context
    ctx Version
    chosenVersion [ExtensionRaw]
    exts [ExtensionID]
    ciphers Maybe String
    serverName Session
    clientSession
    handshakeServerWith ServerParams
    _ Context
    _ Handshake
    _ = TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "unexpected handshake message received in handshakeServerWith", Bool
    True, AlertDescription
    HandshakeFailure)

    -- TLS 1.2 or earlier
    handshakeServerWithTLS12 :: ServerParams
                             -> Context
                             -> Version
                             -> [ExtensionRaw]
                             -> [CipherID]
                             -> Maybe String
                             -> Version
                             -> [CompressionID]
                             -> Session
                             -> IO ()
    handshakeServerWithTLS12 :: ServerParams
    -> Context
    -> Version
    -> [ExtensionRaw]
    -> [ExtensionID]
    -> Maybe String
    -> Version
    -> [CompressionID]
    -> Session
    -> IO ()
    handshakeServerWithTLS12 ServerParams
    sparams Context
    ctx Version
    chosenVersion [ExtensionRaw]
    exts [ExtensionID]
    ciphers Maybe String
    serverName Version
    clientVersion [CompressionID]
    compressions Session
    clientSession = do
        Credentials
    extraCreds <- ServerHooks -> Maybe String -> IO Credentials
    onServerNameIndication (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams) Maybe String
    serverName
        let allCreds :: Credentials
    allCreds = (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
    isCredentialAllowed Version
    chosenVersion [ExtensionRaw]
    exts) (Credentials -> Credentials) -> Credentials -> Credentials
    forall a b. (a -> b) -> a -> b
    $
                           Credentials
    extraCreds Credentials -> Credentials -> Credentials
    forall a. Monoid a => a -> a -> a
    `mappend` Shared -> Credentials
    sharedCredentials (Context -> Shared
    ctxShared Context
    ctx)

        -- If compression is null, commonCompressions should be [0].
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Compression] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Compression]
    commonCompressions) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no compression in common with the client", Bool
    True, AlertDescription
    HandshakeFailure)

        -- When selecting a cipher we must ensure that it is allowed for the
        -- TLS version but also that all its key-exchange requirements
        -- will be met.

        -- Some ciphers require a signature and a hash.  With TLS 1.2 the hash
        -- algorithm is selected from a combination of server configuration and
        -- the client "supported_signatures" extension.  So we cannot pick
        -- such a cipher if no hash is available for it.  It's best to skip this
        -- cipher and pick another one (with another key exchange).

        -- 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
        -- the resulting credentials.

        let possibleGroups :: [Group]
    possibleGroups   = Context -> [ExtensionRaw] -> [Group]
    negotiatedGroupsInCommon Context
    ctx [ExtensionRaw]
    exts
            possibleECGroups :: [Group]
    possibleECGroups = [Group]
    possibleGroups [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    availableECGroups
            possibleFFGroups :: [Group]
    possibleFFGroups = [Group]
    possibleGroups [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    availableFFGroups
            hasCommonGroupForECDHE :: Bool
    hasCommonGroupForECDHE = Bool -> Bool
    not ([Group] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Group]
    possibleECGroups)
            hasCommonGroupForFFDHE :: Bool
    hasCommonGroupForFFDHE = Bool -> Bool
    not ([Group] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Group]
    possibleFFGroups)
            hasCustomGroupForFFDHE :: Bool
    hasCustomGroupForFFDHE = Maybe DHParams -> Bool
    forall a. Maybe a -> Bool
    isJust (ServerParams -> Maybe DHParams
    serverDHEParams ServerParams
    sparams)
            canFFDHE :: Bool
    canFFDHE = Bool
    hasCustomGroupForFFDHE Bool -> Bool -> Bool
    || Bool
    hasCommonGroupForFFDHE
            hasCommonGroup :: Cipher -> Bool
    hasCommonGroup Cipher
    cipher =
                case Cipher -> CipherKeyExchangeType
    cipherKeyExchange Cipher
    cipher of
                    CipherKeyExchangeType
    CipherKeyExchange_DH_Anon      -> Bool
    canFFDHE
                    CipherKeyExchangeType
    CipherKeyExchange_DHE_RSA      -> Bool
    canFFDHE
                    CipherKeyExchangeType
    CipherKeyExchange_DHE_DSS      -> Bool
    canFFDHE
                    CipherKeyExchangeType
    CipherKeyExchange_ECDHE_RSA    -> Bool
    hasCommonGroupForECDHE
                    CipherKeyExchangeType
    CipherKeyExchange_ECDHE_ECDSA  -> Bool
    hasCommonGroupForECDHE
                    CipherKeyExchangeType
    _                              -> Bool
    True -- group not used

            -- Ciphers are selected according to TLS version, availability of
            -- (EC)DHE group and credential depending on key exchange.
            cipherAllowed :: Cipher -> Bool
    cipherAllowed Cipher
    cipher   = Version -> Cipher -> Bool
    cipherAllowedForVersion Version
    chosenVersion Cipher
    cipher Bool -> Bool -> Bool
    && Cipher -> Bool
    hasCommonGroup Cipher
    cipher
            selectCipher :: Credentials -> Credentials -> [Cipher]
    selectCipher Credentials
    credentials Credentials
    signatureCredentials = (Cipher -> Bool) -> [Cipher] -> [Cipher]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Cipher -> Bool
    cipherAllowed (Credentials -> Credentials -> [Cipher]
    commonCiphers Credentials
    credentials Credentials
    signatureCredentials)

            (Credentials
    creds, Credentials
    signatureCreds, [Cipher]
    ciphersFilteredVersion)
                = case Version
    chosenVersion of
                      Version
    TLS12 -> let -- Build a list of all hash/signature algorithms in common between
                                   -- client and server.
                                   possibleHashSigAlgs :: [HashAndSignatureAlgorithm]
    possibleHashSigAlgs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
    hashAndSignaturesInCommon Context
    ctx [ExtensionRaw]
    exts

                                   -- Check that a candidate signature credential will be compatible with
                                   -- client & server hash/signature algorithms.  This returns Just Int
                                   -- in order to sort credentials according to server hash/signature
                                   -- preference.  When the certificate has no matching hash/signature in
                                   -- 'possibleHashSigAlgs' the result is Nothing, and the credential will
                                   -- not be used to sign.  This avoids a failure later in 'decideHashSig'.
                                   signingRank :: Credential -> Maybe Int
    signingRank Credential
    cred =
                                       case Credential -> Maybe PubKey
    credentialDigitalSignatureKey Credential
    cred of
                                           Just PubKey
    pub -> (HashAndSignatureAlgorithm -> Bool)
    -> [HashAndSignatureAlgorithm] -> Maybe Int
    forall a. (a -> Bool) -> [a] -> Maybe Int
    findIndex (PubKey
    pub PubKey -> HashAndSignatureAlgorithm -> Bool
    `signatureCompatible`) [HashAndSignatureAlgorithm]
    possibleHashSigAlgs
                                           Maybe PubKey
    Nothing  -> Maybe Int
    forall a. Maybe a
    Nothing

                                   -- Finally compute credential lists and resulting cipher list.
                                   --
                                   -- We try to keep certificates supported by the client, but
                                   -- fallback to all credentials if this produces no suitable result
                                   -- (see RFC 5246 section 7.4.2 and RFC 8446 section 4.4.2.2).
                                   -- The condition is based on resulting (EC)DHE ciphers so that
                                   -- filtering credentials does not give advantage to a less secure
                                   -- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon.
                                   cltCreds :: Credentials
    cltCreds    = [ExtensionRaw] -> Credentials -> Credentials
    filterCredentialsWithHashSignatures [ExtensionRaw]
    exts Credentials
    allCreds
                                   sigCltCreds :: Credentials
    sigCltCreds = (Credential -> Maybe Int) -> Credentials -> Credentials
    forall a.
    Ord a =>
    (Credential -> Maybe a) -> Credentials -> Credentials
    filterSortCredentials Credential -> Maybe Int
    signingRank Credentials
    cltCreds
                                   sigAllCreds :: Credentials
    sigAllCreds = (Credential -> Maybe Int) -> Credentials -> Credentials
    forall a.
    Ord a =>
    (Credential -> Maybe a) -> Credentials -> Credentials
    filterSortCredentials Credential -> Maybe Int
    signingRank Credentials
    allCreds
                                   cltCiphers :: [Cipher]
    cltCiphers  = Credentials -> Credentials -> [Cipher]
    selectCipher Credentials
    cltCreds Credentials
    sigCltCreds
                                   allCiphers :: [Cipher]
    allCiphers  = Credentials -> Credentials -> [Cipher]
    selectCipher Credentials
    allCreds Credentials
    sigAllCreds

                                   resultTuple :: (Credentials, Credentials, [Cipher])
    resultTuple = if [Cipher] -> Bool
    cipherListCredentialFallback [Cipher]
    cltCiphers
                                                     then (Credentials
    allCreds, Credentials
    sigAllCreds, [Cipher]
    allCiphers)
                                                     else (Credentials
    cltCreds, Credentials
    sigCltCreds, [Cipher]
    cltCiphers)
                                in (Credentials, Credentials, [Cipher])
    resultTuple
                      Version
    _     ->
                        let sigAllCreds :: Credentials
    sigAllCreds = (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials (Maybe PubKey -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe PubKey -> Bool)
    -> (Credential -> Maybe PubKey) -> Credential -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Credential -> Maybe PubKey
    credentialDigitalSignatureKey) Credentials
    allCreds
                            allCiphers :: [Cipher]
    allCiphers  = Credentials -> Credentials -> [Cipher]
    selectCipher Credentials
    allCreds Credentials
    sigAllCreds
                         in (Credentials
    allCreds, Credentials
    sigAllCreds, [Cipher]
    allCiphers)

        -- The shared cipherlist can become empty after filtering for compatible
        -- creds, check now before calling onCipherChoosing, which does not handle
        -- empty lists.
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Cipher] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Cipher]
    ciphersFilteredVersion) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no cipher in common with the client", Bool
    True, AlertDescription
    HandshakeFailure)

        let usedCipher :: Cipher
    usedCipher = ServerHooks -> Version -> [Cipher] -> Cipher
    onCipherChoosing (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams) Version
    chosenVersion [Cipher]
    ciphersFilteredVersion

        Maybe Credential
    cred <- case Cipher -> CipherKeyExchangeType
    cipherKeyExchange Cipher
    usedCipher of
                    CipherKeyExchangeType
    CipherKeyExchange_RSA       -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Credential -> IO (Maybe Credential))
    -> Maybe Credential -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ Credentials -> Maybe Credential
    credentialsFindForDecrypting Credentials
    creds
                    CipherKeyExchangeType
    CipherKeyExchange_DH_Anon   -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return   Maybe Credential
    forall a. Maybe a
    Nothing
                    CipherKeyExchangeType
    CipherKeyExchange_DHE_RSA   -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Credential -> IO (Maybe Credential))
    -> Maybe Credential -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
    credentialsFindForSigning KeyExchangeSignatureAlg
    KX_RSA Credentials
    signatureCreds
                    CipherKeyExchangeType
    CipherKeyExchange_DHE_DSS   -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Credential -> IO (Maybe Credential))
    -> Maybe Credential -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
    credentialsFindForSigning KeyExchangeSignatureAlg
    KX_DSS Credentials
    signatureCreds
                    CipherKeyExchangeType
    CipherKeyExchange_ECDHE_RSA -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Credential -> IO (Maybe Credential))
    -> Maybe Credential -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
    credentialsFindForSigning KeyExchangeSignatureAlg
    KX_RSA Credentials
    signatureCreds
                    CipherKeyExchangeType
    CipherKeyExchange_ECDHE_ECDSA -> Maybe Credential -> IO (Maybe Credential)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe Credential -> IO (Maybe Credential))
    -> Maybe Credential -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
    credentialsFindForSigning KeyExchangeSignatureAlg
    KX_ECDSA Credentials
    signatureCreds
                    CipherKeyExchangeType
    _                           -> TLSError -> IO (Maybe Credential)
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO (Maybe Credential))
    -> TLSError -> IO (Maybe Credential)
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "key exchange algorithm not implemented", Bool
    True, AlertDescription
    HandshakeFailure)

        Bool
    ems <- Context -> Version -> MessageType -> [ExtensionRaw] -> IO Bool
    forall (m :: * -> *).
    MonadIO m =>
    Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
    processExtendedMasterSec Context
    ctx Version
    chosenVersion MessageType
    MsgTClientHello [ExtensionRaw]
    exts
        Maybe SessionData
    resumeSessionData <- case Session
    clientSession of
                (Session (Just ByteString
    clientSessionId)) -> do
                    let resume :: IO (Maybe SessionData)
    resume = IO (Maybe SessionData) -> IO (Maybe SessionData)
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Maybe SessionData) -> IO (Maybe SessionData))
    -> IO (Maybe SessionData) -> IO (Maybe SessionData)
    forall a b. (a -> b) -> a -> b
    $ SessionManager -> ByteString -> IO (Maybe SessionData)
    sessionResume (Shared -> SessionManager
    sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
    forall a b. (a -> b) -> a -> b
    $ Context -> Shared
    ctxShared Context
    ctx) ByteString
    clientSessionId
                    IO (Maybe SessionData)
    resume IO (Maybe SessionData)
    -> (Maybe SessionData -> IO (Maybe SessionData))
    -> IO (Maybe SessionData)
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Maybe String -> Bool -> Maybe SessionData -> IO (Maybe SessionData)
    forall {m :: * -> *}.
    MonadIO m =>
    Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
    validateSession Maybe String
    serverName Bool
    ems
                (Session Maybe ByteString
    Nothing)                -> Maybe SessionData -> IO (Maybe SessionData)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing

        -- Currently, we don't send back EcPointFormats. In this case,
        -- the client chooses EcPointFormat_Uncompressed.
        case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_EcPointFormats [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe EcPointFormatsSupported)
    -> Maybe EcPointFormatsSupported
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe EcPointFormatsSupported
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
            Just (EcPointFormatsSupported [EcPointFormat]
    fs) -> Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [EcPointFormat] -> TLSSt ()
    setClientEcPointFormatSuggest [EcPointFormat]
    fs
            Maybe EcPointFormatsSupported
    _ -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        ServerParams
    -> Maybe Credential
    -> Context
    -> Version
    -> Cipher
    -> Compression
    -> Session
    -> Maybe SessionData
    -> [ExtensionRaw]
    -> IO ()
    doHandshake ServerParams
    sparams Maybe Credential
    cred Context
    ctx Version
    chosenVersion Cipher
    usedCipher Compression
    usedCompression Session
    clientSession Maybe SessionData
    resumeSessionData [ExtensionRaw]
    exts

      where
            commonCiphers :: Credentials -> Credentials -> [Cipher]
    commonCiphers Credentials
    creds Credentials
    sigCreds = (Cipher -> Bool) -> [Cipher] -> [Cipher]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((ExtensionID -> [ExtensionID] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ExtensionID]
    ciphers) (ExtensionID -> Bool) -> (Cipher -> ExtensionID) -> Cipher -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Cipher -> ExtensionID
    cipherID) (ServerParams -> Credentials -> Credentials -> [Cipher]
    getCiphers ServerParams
    sparams Credentials
    creds Credentials
    sigCreds)
            commonCompressions :: [Compression]
    commonCompressions    = [Compression] -> [CompressionID] -> [Compression]
    compressionIntersectID (Supported -> [Compression]
    supportedCompressions (Supported -> [Compression]) -> Supported -> [Compression]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx) [CompressionID]
    compressions
            usedCompression :: Compression
    usedCompression       = [Compression] -> Compression
    forall a. HasCallStack => [a] -> a
    head [Compression]
    commonCompressions

            validateSession :: Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
    validateSession Maybe String
    _   Bool
    _   Maybe SessionData
    Nothing                     = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
            validateSession Maybe String
    sni Bool
    ems m :: Maybe SessionData
    m@(Just SessionData
    sd)
                -- SessionData parameters are assumed to match the local server configuration
                -- so we need to compare only to ClientHello inputs.  Abbreviated handshake
                -- uses the same server_name than full handshake so the same
                -- credentials (and thus ciphers) are available.
                | Version
    clientVersion Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < SessionData -> Version
    sessionVersion SessionData
    sd             = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
                | SessionData -> ExtensionID
    sessionCipher SessionData
    sd ExtensionID -> [ExtensionID] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [ExtensionID]
    ciphers            = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
                | SessionData -> CompressionID
    sessionCompression SessionData
    sd CompressionID -> [CompressionID] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [CompressionID]
    compressions  = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
                | Maybe String -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe String
    sni Bool -> Bool -> Bool
    && SessionData -> Maybe String
    sessionClientSNI SessionData
    sd Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Maybe String
    sni      = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
                | Bool
    ems Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    emsSession                         = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    forall a. Maybe a
    Nothing
                | Bool -> Bool
    not Bool
    ems Bool -> Bool -> Bool
    && Bool
    emsSession                         =
                    let err :: String
    err = String
    "client resumes an EMS session without EMS"
                     in TLSError -> m (Maybe SessionData)
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m (Maybe SessionData))
    -> TLSError -> m (Maybe SessionData)
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    err, Bool
    True, AlertDescription
    HandshakeFailure)
                | Bool
    otherwise                                     = Maybe SessionData -> m (Maybe SessionData)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe SessionData
    m
              where emsSession :: Bool
    emsSession = SessionFlag
    SessionEMS SessionFlag -> [SessionFlag] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` SessionData -> [SessionFlag]
    sessionFlags SessionData
    sd

    doHandshake :: ServerParams -> Maybe Credential -> Context -> Version -> Cipher
                -> Compression -> Session -> Maybe SessionData
                -> [ExtensionRaw] -> IO ()
    doHandshake :: ServerParams
    -> Maybe Credential
    -> Context
    -> Version
    -> Cipher
    -> Compression
    -> Session
    -> Maybe SessionData
    -> [ExtensionRaw]
    -> IO ()
    doHandshake ServerParams
    sparams Maybe Credential
    mcred Context
    ctx Version
    chosenVersion Cipher
    usedCipher Compression
    usedCompression Session
    clientSession Maybe SessionData
    resumeSessionData [ExtensionRaw]
    exts = do
        case Maybe SessionData
    resumeSessionData of
            Maybe SessionData
    Nothing -> do
                IO ()
    handshakeSendServerData
                IO () -> IO ()
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context -> IO ()
    contextFlush Context
    ctx
                -- Receive client info until client Finished.
                ServerParams -> Context -> IO ()
    recvClientData ServerParams
    sparams Context
    ctx
                Context -> Role -> IO ()
    sendChangeCipherAndFinish Context
    ctx Role
    ServerRole
            Just SessionData
    sessionData -> do
                Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (Session -> Bool -> TLSSt ()
    setSession Session
    clientSession Bool
    True)
                Handshake
    serverhello <- Session -> IO Handshake
    makeServerHello Session
    clientSession
                Context -> Packet -> IO ()
    sendPacket Context
    ctx (Packet -> IO ()) -> Packet -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake] -> Packet
    Handshake [Handshake
    serverhello]
                let masterSecret :: ByteString
    masterSecret = SessionData -> ByteString
    sessionSecret SessionData
    sessionData
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Version -> Role -> ByteString -> HandshakeM ()
    setMasterSecret Version
    chosenVersion Role
    ServerRole ByteString
    masterSecret
                Context -> MasterSecret -> IO ()
    forall a. LogLabel a => Context -> a -> IO ()
    logKey Context
    ctx (ByteString -> MasterSecret
    MasterSecret ByteString
    masterSecret)
                Context -> Role -> IO ()
    sendChangeCipherAndFinish Context
    ctx Role
    ServerRole
                Context -> IO ()
    recvChangeCipherAndFinish Context
    ctx
        Context -> IO ()
    handshakeTerminate Context
    ctx
      where
            ---
            -- When the client sends a certificate, check whether
            -- it is acceptable for the application.
            --
            ---
            makeServerHello :: Session -> IO Handshake
    makeServerHello Session
    session = do
                ServerRandom
    srand <- Context -> Version -> [Version] -> IO ServerRandom
    serverRandom Context
    ctx Version
    chosenVersion ([Version] -> IO ServerRandom) -> [Version] -> IO ServerRandom
    forall a b. (a -> b) -> a -> b
    $ Supported -> [Version]
    supportedVersions (Supported -> [Version]) -> Supported -> [Version]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams
                case Maybe Credential
    mcred of
                    Just Credential
    cred          -> Context -> Credential -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
    storePrivInfoServer Context
    ctx Credential
    cred
                    Maybe Credential
    _                  -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () -- return a sensible error

                -- in TLS12, we need to check as well the certificates we are sending if they have in the extension
                -- the necessary bits set.
                Bool
    secReneg   <- Context -> TLSSt Bool -> IO Bool
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Bool
    getSecureRenegotiation
                [ExtensionRaw]
    secRengExt <- if Bool
    secReneg
                        then do
                                ByteString
    vf <- Context -> TLSSt ByteString -> IO ByteString
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt ByteString -> IO ByteString)
    -> TLSSt ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ do
                                        ByteString
    cvf <- Role -> TLSSt ByteString
    getVerifiedData Role
    ClientRole
                                        ByteString
    svf <- Role -> TLSSt ByteString
    getVerifiedData Role
    ServerRole
                                        ByteString -> TLSSt ByteString
    forall a. a -> TLSSt a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString -> TLSSt ByteString) -> ByteString -> TLSSt ByteString
    forall a b. (a -> b) -> a -> b
    $ SecureRenegotiation -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (ByteString -> Maybe ByteString -> SecureRenegotiation
    SecureRenegotiation ByteString
    cvf (Maybe ByteString -> SecureRenegotiation)
    -> Maybe ByteString -> SecureRenegotiation
    forall a b. (a -> b) -> a -> b
    $ ByteString -> Maybe ByteString
    forall a. a -> Maybe a
    Just ByteString
    svf)
                                [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_SecureRenegotiation ByteString
    vf ]
                        else [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                Bool
    ems <- Context -> HandshakeM Bool -> IO Bool
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM Bool
    getExtendedMasterSec
                let emsExt :: [ExtensionRaw]
    emsExt | Bool
    ems = let raw :: ByteString
    raw = ExtendedMasterSecret -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode ExtendedMasterSecret
    ExtendedMasterSecret
                                    in [ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_ExtendedMasterSecret ByteString
    raw ]
                           | Bool
    otherwise = []
                [ExtensionRaw]
    protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
    applicationProtocol Context
    ctx [ExtensionRaw]
    exts ServerParams
    sparams
                [ExtensionRaw]
    sniExt   <- do
                    Bool
    resuming <- Context -> TLSSt Bool -> IO Bool
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Bool
    isSessionResuming
                    if Bool
    resuming
                      then [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                      else do
                        Maybe String
    msni <- Context -> TLSSt (Maybe String) -> IO (Maybe String)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe String)
    getClientSNI
                        case Maybe String
    msni of
                          -- RFC6066: In this event, the server SHALL include
                          -- an extension of type "server_name" in the
                          -- (extended) server hello. The "extension_data"
                          -- field of this extension SHALL be empty.
                          Just String
    _  -> [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_ServerName ByteString
    ""]
                          Maybe String
    Nothing -> [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
                let extensions :: [ExtensionRaw]
    extensions = Shared -> [ExtensionRaw]
    sharedHelloExtensions (ServerParams -> Shared
    serverShared ServerParams
    sparams)
                              [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [ExtensionRaw]
    secRengExt [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [ExtensionRaw]
    emsExt [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [ExtensionRaw]
    protoExt [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [ExtensionRaw]
    sniExt
                Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (Version -> TLSSt ()
    setVersion Version
    chosenVersion)
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Version -> ServerRandom -> Cipher -> Compression -> HandshakeM ()
    setServerHelloParameters Version
    chosenVersion ServerRandom
    srand Cipher
    usedCipher Compression
    usedCompression
                Handshake -> IO Handshake
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Handshake -> IO Handshake) -> Handshake -> IO Handshake
    forall a b. (a -> b) -> a -> b
    $ Version
    -> ServerRandom
    -> Session
    -> ExtensionID
    -> CompressionID
    -> [ExtensionRaw]
    -> Handshake
    ServerHello Version
    chosenVersion ServerRandom
    srand Session
    session (Cipher -> ExtensionID
    cipherID Cipher
    usedCipher)
                                                   (Compression -> CompressionID
    compressionID Compression
    usedCompression) [ExtensionRaw]
    extensions

            handshakeSendServerData :: IO ()
    handshakeSendServerData = do
                Session
    serverSession <- Context -> IO Session
    newSession Context
    ctx
                Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (Session -> Bool -> TLSSt ()
    setSession Session
    serverSession Bool
    False)
                Handshake
    serverhello   <- Session -> IO Handshake
    makeServerHello Session
    serverSession
                -- send ServerHello & Certificate & ServerKeyXchg & CertReq
                let certMsg :: Handshake
    certMsg = case Maybe Credential
    mcred of
                                Just (CertificateChain
    srvCerts, PrivKey
    _) -> CertificateChain -> Handshake
    Certificates CertificateChain
    srvCerts
                                Maybe Credential
    _                  -> CertificateChain -> Handshake
    Certificates (CertificateChain -> Handshake) -> CertificateChain -> Handshake
    forall a b. (a -> b) -> a -> b
    $ [SignedExact Certificate] -> CertificateChain
    CertificateChain []
                Context -> Packet -> IO ()
    sendPacket Context
    ctx (Packet -> IO ()) -> Packet -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake] -> Packet
    Handshake [ Handshake
    serverhello, Handshake
    certMsg ]

                -- send server key exchange if needed
                Maybe ServerKeyXchgAlgorithmData
    skx <- case Cipher -> CipherKeyExchangeType
    cipherKeyExchange Cipher
    usedCipher of
                            CipherKeyExchangeType
    CipherKeyExchange_DH_Anon -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
    forall a. a -> Maybe a
    Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
    -> IO ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ServerKeyXchgAlgorithmData
    generateSKX_DH_Anon
                            CipherKeyExchangeType
    CipherKeyExchange_DHE_RSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
    forall a. a -> Maybe a
    Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
    -> IO ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_DHE KeyExchangeSignatureAlg
    KX_RSA
                            CipherKeyExchangeType
    CipherKeyExchange_DHE_DSS -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
    forall a. a -> Maybe a
    Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
    -> IO ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_DHE KeyExchangeSignatureAlg
    KX_DSS
                            CipherKeyExchangeType
    CipherKeyExchange_ECDHE_RSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
    forall a. a -> Maybe a
    Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
    -> IO ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_ECDHE KeyExchangeSignatureAlg
    KX_RSA
                            CipherKeyExchangeType
    CipherKeyExchange_ECDHE_ECDSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
    forall a. a -> Maybe a
    Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
    -> IO ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_ECDHE KeyExchangeSignatureAlg
    KX_ECDSA
                            CipherKeyExchangeType
    _                         -> Maybe ServerKeyXchgAlgorithmData
    -> IO (Maybe ServerKeyXchgAlgorithmData)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe ServerKeyXchgAlgorithmData
    forall a. Maybe a
    Nothing
                IO ()
    -> (ServerKeyXchgAlgorithmData -> IO ())
    -> Maybe ServerKeyXchgAlgorithmData
    -> IO ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) (Context -> Packet -> IO ()
    sendPacket Context
    ctx (Packet -> IO ())
    -> (ServerKeyXchgAlgorithmData -> Packet)
    -> ServerKeyXchgAlgorithmData
    -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Handshake] -> Packet
    Handshake ([Handshake] -> Packet)
    -> (ServerKeyXchgAlgorithmData -> [Handshake])
    -> ServerKeyXchgAlgorithmData
    -> Packet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Handshake -> [Handshake] -> [Handshake]
    forall a. a -> [a] -> [a]
    :[]) (Handshake -> [Handshake])
    -> (ServerKeyXchgAlgorithmData -> Handshake)
    -> ServerKeyXchgAlgorithmData
    -> [Handshake]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ServerKeyXchgAlgorithmData -> Handshake
    ServerKeyXchg) Maybe ServerKeyXchgAlgorithmData
    skx

                -- FIXME we don't do this on a Anonymous server

                -- When configured, send a certificate request with the DNs of all
                -- configured CA certificates.
                --
                -- Client certificates MUST NOT be accepted if not requested.
                --
                Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ServerParams -> Bool
    serverWantClientCert ServerParams
    sparams) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                    Version
    usedVersion <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
                    let defaultCertTypes :: [CertificateType]
    defaultCertTypes = [ CertificateType
    CertificateType_RSA_Sign
                                           , CertificateType
    CertificateType_DSS_Sign
                                           , CertificateType
    CertificateType_ECDSA_Sign
                                           ]
                        ([CertificateType]
    certTypes, Maybe [HashAndSignatureAlgorithm]
    hashSigs)
                            | Version
    usedVersion Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < Version
    TLS12 = ([CertificateType]
    defaultCertTypes, Maybe [HashAndSignatureAlgorithm]
    forall a. Maybe a
    Nothing)
                            | Bool
    otherwise =
                                let as :: [HashAndSignatureAlgorithm]
    as = Supported -> [HashAndSignatureAlgorithm]
    supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
    -> Supported -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx
                                 in ([CertificateType] -> [CertificateType]
    forall a. Eq a => [a] -> [a]
    nub ([CertificateType] -> [CertificateType])
    -> [CertificateType] -> [CertificateType]
    forall a b. (a -> b) -> a -> b
    $ (HashAndSignatureAlgorithm -> Maybe CertificateType)
    -> [HashAndSignatureAlgorithm] -> [CertificateType]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe HashAndSignatureAlgorithm -> Maybe CertificateType
    hashSigToCertType [HashAndSignatureAlgorithm]
    as, [HashAndSignatureAlgorithm] -> Maybe [HashAndSignatureAlgorithm]
    forall a. a -> Maybe a
    Just [HashAndSignatureAlgorithm]
    as)
                        creq :: Handshake
    creq = [CertificateType]
    -> Maybe [HashAndSignatureAlgorithm]
    -> [DistinguishedName]
    -> Handshake
    CertRequest [CertificateType]
    certTypes Maybe [HashAndSignatureAlgorithm]
    hashSigs
                                   ((SignedExact Certificate -> DistinguishedName)
    -> [SignedExact Certificate] -> [DistinguishedName]
    forall a b. (a -> b) -> [a] -> [b]
    map SignedExact Certificate -> DistinguishedName
    extractCAname ([SignedExact Certificate] -> [DistinguishedName])
    -> [SignedExact Certificate] -> [DistinguishedName]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> [SignedExact Certificate]
    serverCACertificates ServerParams
    sparams)
                    Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> HandshakeM ()
    setCertReqSent Bool
    True
                    Context -> Packet -> IO ()
    sendPacket Context
    ctx ([Handshake] -> Packet
    Handshake [Handshake
    creq])

                -- Send HelloDone
                Context -> Packet -> IO ()
    sendPacket Context
    ctx ([Handshake] -> Packet
    Handshake [Handshake
    ServerHelloDone])

            setup_DHE :: IO ServerDHParams
    setup_DHE = do
                let possibleFFGroups :: [Group]
    possibleFFGroups = Context -> [ExtensionRaw] -> [Group]
    negotiatedGroupsInCommon Context
    ctx [ExtensionRaw]
    exts [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    availableFFGroups
                (DHParams
    dhparams, DHPrivate
    priv, DHPublic
    pub) <-
                        case [Group]
    possibleFFGroups of
                            []  ->
                                let dhparams :: DHParams
    dhparams = String -> Maybe DHParams -> DHParams
    forall a. String -> Maybe a -> a
    fromJust String
    "server DHE Params" (Maybe DHParams -> DHParams) -> Maybe DHParams -> DHParams
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Maybe DHParams
    serverDHEParams ServerParams
    sparams
                                 in case DHParams -> Maybe Group
    findFiniteFieldGroup DHParams
    dhparams of
                                        Just Group
    g  -> do
                                            Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Group -> HandshakeM ()
    setNegotiatedGroup Group
    g
                                            Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
    generateFFDHE Context
    ctx Group
    g
                                        Maybe Group
    Nothing -> do
                                            (DHPrivate
    priv, DHPublic
    pub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
    generateDHE Context
    ctx DHParams
    dhparams
                                            (DHParams, DHPrivate, DHPublic)
    -> IO (DHParams, DHPrivate, DHPublic)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DHParams
    dhparams, DHPrivate
    priv, DHPublic
    pub)
                            Group
    g:[Group]
    _ -> do
                                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Group -> HandshakeM ()
    setNegotiatedGroup Group
    g
                                Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
    generateFFDHE Context
    ctx Group
    g

                let serverParams :: ServerDHParams
    serverParams = DHParams -> DHPublic -> ServerDHParams
    serverDHParamsFrom DHParams
    dhparams DHPublic
    pub

                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ServerDHParams -> HandshakeM ()
    setServerDHParams ServerDHParams
    serverParams
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ DHPrivate -> HandshakeM ()
    setDHPrivate DHPrivate
    priv
                ServerDHParams -> IO ServerDHParams
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ServerDHParams
    serverParams

            -- Choosing a hash algorithm to sign (EC)DHE parameters
            -- in ServerKeyExchange. Hash algorithm is not suggested by
            -- the chosen cipher suite. So, it should be selected based on
            -- the "signature_algorithms" extension in a client hello.
            -- If RSA is also used for key exchange, this function is
            -- not called.
            decideHashSig :: PubKey -> IO (Maybe HashAndSignatureAlgorithm)
    decideHashSig PubKey
    pubKey = do
                Version
    usedVersion <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
                case Version
    usedVersion of
                  Version
    TLS12 -> do
                      let hashSigs :: [HashAndSignatureAlgorithm]
    hashSigs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
    hashAndSignaturesInCommon Context
    ctx [ExtensionRaw]
    exts
                      case (HashAndSignatureAlgorithm -> Bool)
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (PubKey
    pubKey PubKey -> HashAndSignatureAlgorithm -> Bool
    `signatureCompatible`) [HashAndSignatureAlgorithm]
    hashSigs of
                          []  -> String -> IO (Maybe HashAndSignatureAlgorithm)
    forall a. HasCallStack => String -> a
    error (String
    "no hash signature for " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ PubKey -> String
    pubkeyType PubKey
    pubKey)
                          HashAndSignatureAlgorithm
    x:[HashAndSignatureAlgorithm]
    _ -> Maybe HashAndSignatureAlgorithm
    -> IO (Maybe HashAndSignatureAlgorithm)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe HashAndSignatureAlgorithm
     -> IO (Maybe HashAndSignatureAlgorithm))
    -> Maybe HashAndSignatureAlgorithm
    -> IO (Maybe HashAndSignatureAlgorithm)
    forall a b. (a -> b) -> a -> b
    $ HashAndSignatureAlgorithm -> Maybe HashAndSignatureAlgorithm
    forall a. a -> Maybe a
    Just HashAndSignatureAlgorithm
    x
                  Version
    _     -> Maybe HashAndSignatureAlgorithm
    -> IO (Maybe HashAndSignatureAlgorithm)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe HashAndSignatureAlgorithm
    forall a. Maybe a
    Nothing

            generateSKX_DHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_DHE KeyExchangeSignatureAlg
    kxsAlg = do
                ServerDHParams
    serverParams  <- IO ServerDHParams
    setup_DHE
                PubKey
    pubKey <- Context -> IO PubKey
    forall (m :: * -> *). MonadIO m => Context -> m PubKey
    getLocalPublicKey Context
    ctx
                Maybe HashAndSignatureAlgorithm
    mhashSig <- PubKey -> IO (Maybe HashAndSignatureAlgorithm)
    decideHashSig PubKey
    pubKey
                DigitallySigned
    signed <- Context
    -> ServerDHParams
    -> PubKey
    -> Maybe HashAndSignatureAlgorithm
    -> IO DigitallySigned
    digitallySignDHParams Context
    ctx ServerDHParams
    serverParams PubKey
    pubKey Maybe HashAndSignatureAlgorithm
    mhashSig
                case KeyExchangeSignatureAlg
    kxsAlg of
                    KeyExchangeSignatureAlg
    KX_RSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
    -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a b. (a -> b) -> a -> b
    $ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
    SKX_DHE_RSA ServerDHParams
    serverParams DigitallySigned
    signed
                    KeyExchangeSignatureAlg
    KX_DSS -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
    -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a b. (a -> b) -> a -> b
    $ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
    SKX_DHE_DSS ServerDHParams
    serverParams DigitallySigned
    signed
                    KeyExchangeSignatureAlg
    _      -> String -> IO ServerKeyXchgAlgorithmData
    forall a. HasCallStack => String -> a
    error (String
    "generate skx_dhe unsupported key exchange signature: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ KeyExchangeSignatureAlg -> String
    forall a. Show a => a -> String
    show KeyExchangeSignatureAlg
    kxsAlg)

            generateSKX_DH_Anon :: IO ServerKeyXchgAlgorithmData
    generateSKX_DH_Anon = ServerDHParams -> ServerKeyXchgAlgorithmData
    SKX_DH_Anon (ServerDHParams -> ServerKeyXchgAlgorithmData)
    -> IO ServerDHParams -> IO ServerKeyXchgAlgorithmData
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ServerDHParams
    setup_DHE

            setup_ECDHE :: Group -> IO ServerECDHParams
    setup_ECDHE Group
    grp = do
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Group -> HandshakeM ()
    setNegotiatedGroup Group
    grp
                (GroupPrivate
    srvpri, GroupPublic
    srvpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
    generateECDHE Context
    ctx Group
    grp
                let serverParams :: ServerECDHParams
    serverParams = Group -> GroupPublic -> ServerECDHParams
    ServerECDHParams Group
    grp GroupPublic
    srvpub
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ServerECDHParams -> HandshakeM ()
    setServerECDHParams ServerECDHParams
    serverParams
                Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ GroupPrivate -> HandshakeM ()
    setGroupPrivate GroupPrivate
    srvpri
                ServerECDHParams -> IO ServerECDHParams
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ServerECDHParams
    serverParams

            generateSKX_ECDHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
    generateSKX_ECDHE KeyExchangeSignatureAlg
    kxsAlg = do
                let possibleECGroups :: [Group]
    possibleECGroups = Context -> [ExtensionRaw] -> [Group]
    negotiatedGroupsInCommon Context
    ctx [ExtensionRaw]
    exts [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    availableECGroups
                Group
    grp <- case [Group]
    possibleECGroups of
                         []  -> TLSError -> IO Group
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO Group) -> TLSError -> IO Group
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no common group", Bool
    True, AlertDescription
    HandshakeFailure)
                         Group
    g:[Group]
    _ -> Group -> IO Group
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Group
    g
                ServerECDHParams
    serverParams <- Group -> IO ServerECDHParams
    setup_ECDHE Group
    grp
                PubKey
    pubKey <- Context -> IO PubKey
    forall (m :: * -> *). MonadIO m => Context -> m PubKey
    getLocalPublicKey Context
    ctx
                Maybe HashAndSignatureAlgorithm
    mhashSig <- PubKey -> IO (Maybe HashAndSignatureAlgorithm)
    decideHashSig PubKey
    pubKey
                DigitallySigned
    signed <- Context
    -> ServerECDHParams
    -> PubKey
    -> Maybe HashAndSignatureAlgorithm
    -> IO DigitallySigned
    digitallySignECDHParams Context
    ctx ServerECDHParams
    serverParams PubKey
    pubKey Maybe HashAndSignatureAlgorithm
    mhashSig
                case KeyExchangeSignatureAlg
    kxsAlg of
                    KeyExchangeSignatureAlg
    KX_RSA   -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
    -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a b. (a -> b) -> a -> b
    $ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
    SKX_ECDHE_RSA ServerECDHParams
    serverParams DigitallySigned
    signed
                    KeyExchangeSignatureAlg
    KX_ECDSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
    -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
    forall a b. (a -> b) -> a -> b
    $ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
    SKX_ECDHE_ECDSA ServerECDHParams
    serverParams DigitallySigned
    signed
                    KeyExchangeSignatureAlg
    _        -> String -> IO ServerKeyXchgAlgorithmData
    forall a. HasCallStack => String -> a
    error (String
    "generate skx_ecdhe unsupported key exchange signature: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ KeyExchangeSignatureAlg -> String
    forall a. Show a => a -> String
    show KeyExchangeSignatureAlg
    kxsAlg)

            -- create a DigitallySigned objects for DHParams or ECDHParams.

    -- | receive Client data in handshake until the Finished handshake.
    --
    --      <- [certificate]
    --      <- client key xchg
    --      <- [cert verify]
    --      <- change cipher
    --      <- finish
    --
    recvClientData :: ServerParams -> Context -> IO ()
    recvClientData :: ServerParams -> Context -> IO ()
    recvClientData ServerParams
    sparams Context
    ctx = Context -> RecvState IO -> IO ()
    runRecvState Context
    ctx ((Handshake -> IO (RecvState IO)) -> RecvState IO
    forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
    RecvStateHandshake Handshake -> IO (RecvState IO)
    processClientCertificate)
      where processClientCertificate :: Handshake -> IO (RecvState IO)
    processClientCertificate (Certificates CertificateChain
    certs) = do
                ServerParams -> Context -> CertificateChain -> IO ()
    clientCertificate ServerParams
    sparams Context
    ctx CertificateChain
    certs

                -- FIXME: We should check whether the certificate
                -- matches our request and that we support
                -- verifying with that certificate.

                RecvState IO -> IO (RecvState IO)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RecvState IO -> IO (RecvState IO))
    -> RecvState IO -> IO (RecvState IO)
    forall a b. (a -> b) -> a -> b
    $ (Handshake -> IO (RecvState IO)) -> RecvState IO
    forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
    RecvStateHandshake Handshake -> IO (RecvState IO)
    forall {m :: * -> *}. MonadIO m => Handshake -> m (RecvState IO)
    processClientKeyExchange

            processClientCertificate Handshake
    p = Handshake -> IO (RecvState IO)
    forall {m :: * -> *}. MonadIO m => Handshake -> m (RecvState IO)
    processClientKeyExchange Handshake
    p

            -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,
            -- so we must process any packet, and in case of handshake call processHandshake manually.
            processClientKeyExchange :: Handshake -> m (RecvState IO)
    processClientKeyExchange (ClientKeyXchg ClientKeyXchgAlgorithmData
    _) = RecvState IO -> m (RecvState IO)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RecvState IO -> m (RecvState IO))
    -> RecvState IO -> m (RecvState IO)
    forall a b. (a -> b) -> a -> b
    $ (Packet -> IO (RecvState IO)) -> RecvState IO
    forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
    RecvStateNext Packet -> IO (RecvState IO)
    forall {m :: * -> *}. MonadIO m => Packet -> IO (RecvState m)
    processCertificateVerify
            processClientKeyExchange Handshake
    p                 = String -> Maybe String -> m (RecvState IO)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake -> String
    forall a. Show a => a -> String
    show Handshake
    p) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "client key exchange")

            -- Check whether the client correctly signed the handshake.
            -- If not, ask the application on how to proceed.
            --
            processCertificateVerify :: Packet -> IO (RecvState m)
    processCertificateVerify (Handshake [hs :: Handshake
    hs@(CertVerify DigitallySigned
    dsig)]) = do
                Context -> Handshake -> IO ()
    processHandshake Context
    ctx Handshake
    hs

                CertificateChain
    certs <- Context -> String -> IO CertificateChain
    forall (m :: * -> *).
    MonadIO m =>
    Context -> String -> m CertificateChain
    checkValidClientCertChain Context
    ctx String
    "change cipher message expected"

                Version
    usedVersion <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
                -- Fetch all handshake messages up to now.
                ByteString
    msgs  <- Context -> HandshakeM ByteString -> IO ByteString
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM ByteString -> IO ByteString)
    -> HandshakeM ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ [ByteString] -> ByteString
    B.concat ([ByteString] -> ByteString)
    -> HandshakeM [ByteString] -> HandshakeM ByteString
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> HandshakeM [ByteString]
    getHandshakeMessages

                PubKey
    pubKey <- Context -> HandshakeM PubKey -> IO PubKey
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM PubKey
    getRemotePublicKey
                Version -> PubKey -> IO ()
    forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
    checkDigitalSignatureKey Version
    usedVersion PubKey
    pubKey

                Bool
    verif <- Context
    -> Version -> PubKey -> ByteString -> DigitallySigned -> IO Bool
    checkCertificateVerify Context
    ctx Version
    usedVersion PubKey
    pubKey ByteString
    msgs DigitallySigned
    dsig
                ServerParams -> Context -> CertificateChain -> Bool -> IO ()
    clientCertVerify ServerParams
    sparams Context
    ctx CertificateChain
    certs Bool
    verif
                RecvState m -> IO (RecvState m)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RecvState m -> IO (RecvState m))
    -> RecvState m -> IO (RecvState m)
    forall a b. (a -> b) -> a -> b
    $ (Packet -> m (RecvState m)) -> RecvState m
    forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
    RecvStateNext Packet -> m (RecvState m)
    forall {m :: * -> *} {m :: * -> *}.
    (MonadIO m, MonadIO m) =>
    Packet -> m (RecvState m)
    expectChangeCipher

            processCertificateVerify Packet
    p = do
                Maybe CertificateChain
    chain <- Context
    -> HandshakeM (Maybe CertificateChain)
    -> IO (Maybe CertificateChain)
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM (Maybe CertificateChain)
    getClientCertChain
                case Maybe CertificateChain
    chain of
                    Just CertificateChain
    cc | CertificateChain -> Bool
    isNullCertificateChain CertificateChain
    cc -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                            | Bool
    otherwise                 -> TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "cert verify message missing", Bool
    True, AlertDescription
    UnexpectedMessage)
                    Maybe CertificateChain
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Packet -> IO (RecvState m)
    forall {m :: * -> *} {m :: * -> *}.
    (MonadIO m, MonadIO m) =>
    Packet -> m (RecvState m)
    expectChangeCipher Packet
    p

            expectChangeCipher :: Packet -> m (RecvState m)
    expectChangeCipher Packet
    ChangeCipherSpec = do
                RecvState m -> m (RecvState m)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (RecvState m -> m (RecvState m)) -> RecvState m -> m (RecvState m)
    forall a b. (a -> b) -> a -> b
    $ (Handshake -> m (RecvState m)) -> RecvState m
    forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
    RecvStateHandshake Handshake -> m (RecvState m)
    forall {m :: * -> *} {m :: * -> *}.
    MonadIO m =>
    Handshake -> m (RecvState m)
    expectFinish

            expectChangeCipher Packet
    p                = String -> Maybe String -> m (RecvState m)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Packet -> String
    forall a. Show a => a -> String
    show Packet
    p) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "change cipher")

            expectFinish :: Handshake -> m (RecvState m)
    expectFinish (Finished ByteString
    _) = RecvState m -> m (RecvState m)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return RecvState m
    forall (m :: * -> *). RecvState m
    RecvStateDone
            expectFinish Handshake
    p            = String -> Maybe String -> m (RecvState m)
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake -> String
    forall a. Show a => a -> String
    show Handshake
    p) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "Handshake Finished")

    checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain
    checkValidClientCertChain :: forall (m :: * -> *).
    MonadIO m =>
    Context -> String -> m CertificateChain
    checkValidClientCertChain Context
    ctx String
    errmsg = do
        Maybe CertificateChain
    chain <- Context
    -> HandshakeM (Maybe CertificateChain)
    -> m (Maybe CertificateChain)
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM (Maybe CertificateChain)
    getClientCertChain
        let throwerror :: TLSError
    throwerror = (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    errmsg , Bool
    True, AlertDescription
    UnexpectedMessage)
        case Maybe CertificateChain
    chain of
            Maybe CertificateChain
    Nothing -> TLSError -> m CertificateChain
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore TLSError
    throwerror
            Just CertificateChain
    cc | CertificateChain -> Bool
    isNullCertificateChain CertificateChain
    cc -> TLSError -> m CertificateChain
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore TLSError
    throwerror
                    | Bool
    otherwise                 -> CertificateChain -> m CertificateChain
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return CertificateChain
    cc

    hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
    hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
    hashAndSignaturesInCommon Context
    ctx [ExtensionRaw]
    exts =
        let cHashSigs :: [HashAndSignatureAlgorithm]
    cHashSigs = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_SignatureAlgorithms [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe SignatureAlgorithms)
    -> Maybe SignatureAlgorithms
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe SignatureAlgorithms
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
                -- See Section 7.4.1.4.1 of RFC 5246.
                Maybe SignatureAlgorithms
    Nothing -> [(HashAlgorithm
    HashSHA1, SignatureAlgorithm
    SignatureECDSA)
                           ,(HashAlgorithm
    HashSHA1, SignatureAlgorithm
    SignatureRSA)
                           ,(HashAlgorithm
    HashSHA1, SignatureAlgorithm
    SignatureDSS)]
                Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
    sas) -> [HashAndSignatureAlgorithm]
    sas
            sHashSigs :: [HashAndSignatureAlgorithm]
    sHashSigs = Supported -> [HashAndSignatureAlgorithm]
    supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
    -> Supported -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx
            -- The values in the "signature_algorithms" extension
            -- are in descending order of preference.
            -- However here the algorithms are selected according
            -- to server preference in 'supportedHashSignatures'.
         in [HashAndSignatureAlgorithm]
    sHashSigs [HashAndSignatureAlgorithm]
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [HashAndSignatureAlgorithm]
    cHashSigs

    negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
    negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
    negotiatedGroupsInCommon Context
    ctx [ExtensionRaw]
    exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_NegotiatedGroups [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe NegotiatedGroups) -> Maybe NegotiatedGroups
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe NegotiatedGroups
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
        Just (NegotiatedGroups [Group]
    clientGroups) ->
            let serverGroups :: [Group]
    serverGroups = Supported -> [Group]
    supportedGroups (Context -> Supported
    ctxSupported Context
    ctx)
            in [Group]
    serverGroups [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    clientGroups
        Maybe NegotiatedGroups
    _                                    -> []

    credentialDigitalSignatureKey :: Credential -> Maybe PubKey
    credentialDigitalSignatureKey :: Credential -> Maybe PubKey
    credentialDigitalSignatureKey Credential
    cred
        | (PubKey, PrivKey) -> Bool
    isDigitalSignaturePair (PubKey, PrivKey)
    keys = PubKey -> Maybe PubKey
    forall a. a -> Maybe a
    Just PubKey
    pubkey
        | Bool
    otherwise = Maybe PubKey
    forall a. Maybe a
    Nothing
      where keys :: (PubKey, PrivKey)
    keys@(PubKey
    pubkey, PrivKey
    _) = Credential -> (PubKey, PrivKey)
    credentialPublicPrivateKeys Credential
    cred

    filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials :: (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials Credential -> Bool
    p (Credentials [Credential]
    l) = [Credential] -> Credentials
    Credentials ((Credential -> Bool) -> [Credential] -> [Credential]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Credential -> Bool
    p [Credential]
    l)

    filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
    filterSortCredentials :: forall a.
    Ord a =>
    (Credential -> Maybe a) -> Credentials -> Credentials
    filterSortCredentials Credential -> Maybe a
    rankFun (Credentials [Credential]
    creds) =
        let orderedPairs :: [(Maybe a, Credential)]
    orderedPairs = ((Maybe a, Credential) -> Maybe a)
    -> [(Maybe a, Credential)] -> [(Maybe a, Credential)]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn (Maybe a, Credential) -> Maybe a
    forall a b. (a, b) -> a
    fst [ (Credential -> Maybe a
    rankFun Credential
    cred, Credential
    cred) | Credential
    cred <- [Credential]
    creds ]
         in [Credential] -> Credentials
    Credentials [ Credential
    cred | (Just a
    _, Credential
    cred) <- [(Maybe a, Credential)]
    orderedPairs ]

    isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool
    isCredentialAllowed :: Version -> [ExtensionRaw] -> Credential -> Bool
    isCredentialAllowed Version
    ver [ExtensionRaw]
    exts Credential
    cred =
        PubKey
    pubkey PubKey -> Version -> Bool
    `versionCompatible` Version
    ver Bool -> Bool -> Bool
    && (Group -> Bool) -> PubKey -> Bool
    satisfiesEcPredicate Group -> Bool
    p PubKey
    pubkey
      where
        (PubKey
    pubkey, PrivKey
    _) = Credential -> (PubKey, PrivKey)
    credentialPublicPrivateKeys Credential
    cred
        -- ECDSA keys are tested against supported elliptic curves until TLS12 but
        -- not after.  With TLS13, the curve is linked to the signature algorithm
        -- and client support is tested with signatureCompatible13.
        p :: Group -> Bool
    p | Version
    ver Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    < Version
    TLS13 = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_NegotiatedGroups [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe NegotiatedGroups) -> Maybe NegotiatedGroups
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe NegotiatedGroups
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
              Maybe NegotiatedGroups
    Nothing                    -> Bool -> Group -> Bool
    forall a b. a -> b -> a
    const Bool
    True
              Just (NegotiatedGroups [Group]
    sg) -> (Group -> [Group] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Group]
    sg)
          | Bool
    otherwise   = Bool -> Group -> Bool
    forall a b. a -> b -> a
    const Bool
    True

    -- Filters a list of candidate credentials with credentialMatchesHashSignatures.
    --
    -- Algorithms to filter with are taken from "signature_algorithms_cert"
    -- extension when it exists, else from "signature_algorithms" when clients do
    -- not implement the new extension (see RFC 8446 section 4.2.3).
    --
    -- Resulting credential list can be used as input to the hybrid cipher-and-
    -- certificate selection for TLS12, or to the direct certificate selection
    -- simplified with TLS13.  As filtering credential signatures with client-
    -- advertised algorithms is not supposed to cause negotiation failure, in case
    -- of dead end with the subsequent selection process, this process should always
    -- be restarted with the unfiltered credential list as input (see fallback
    -- certificate chains, described in same RFC section).
    --
    -- Calling code should not forget to apply constraints of extension
    -- "signature_algorithms" to any signature-based key exchange derived from the
    -- output credentials.  Respecting client constraints on KX signatures is
    -- mandatory but not implemented by this function.
    filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials
    filterCredentialsWithHashSignatures :: [ExtensionRaw] -> Credentials -> Credentials
    filterCredentialsWithHashSignatures [ExtensionRaw]
    exts =
        case ExtensionID -> Maybe SignatureAlgorithmsCert
    forall {b}. Extension b => ExtensionID -> Maybe b
    withExt ExtensionID
    extensionID_SignatureAlgorithmsCert of
            Just (SignatureAlgorithmsCert [HashAndSignatureAlgorithm]
    sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
    withAlgs [HashAndSignatureAlgorithm]
    sas
            Maybe SignatureAlgorithmsCert
    Nothing ->
                case ExtensionID -> Maybe SignatureAlgorithms
    forall {b}. Extension b => ExtensionID -> Maybe b
    withExt ExtensionID
    extensionID_SignatureAlgorithms of
                    Maybe SignatureAlgorithms
    Nothing                        -> Credentials -> Credentials
    forall a. a -> a
    id
                    Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
    sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
    withAlgs [HashAndSignatureAlgorithm]
    sas
      where
        withExt :: ExtensionID -> Maybe b
    withExt ExtensionID
    extId = ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extId [ExtensionRaw]
    exts Maybe ByteString -> (ByteString -> Maybe b) -> Maybe b
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe b
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello
        withAlgs :: [HashAndSignatureAlgorithm] -> Credentials -> Credentials
    withAlgs [HashAndSignatureAlgorithm]
    sas = (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials ([HashAndSignatureAlgorithm] -> Credential -> Bool
    credentialMatchesHashSignatures [HashAndSignatureAlgorithm]
    sas)

    -- returns True if certificate filtering with "signature_algorithms_cert" /
    -- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so
    -- handshake with lower security)
    cipherListCredentialFallback :: [Cipher] -> Bool
    cipherListCredentialFallback :: [Cipher] -> Bool
    cipherListCredentialFallback = (Cipher -> Bool) -> [Cipher] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Cipher -> Bool
    nonDH
      where
        nonDH :: Cipher -> Bool
    nonDH Cipher
    x = case Cipher -> CipherKeyExchangeType
    cipherKeyExchange Cipher
    x of
            CipherKeyExchangeType
    CipherKeyExchange_DHE_RSA     -> Bool
    False
            CipherKeyExchangeType
    CipherKeyExchange_DHE_DSS     -> Bool
    False
            CipherKeyExchangeType
    CipherKeyExchange_ECDHE_RSA   -> Bool
    False
            CipherKeyExchangeType
    CipherKeyExchange_ECDHE_ECDSA -> Bool
    False
            CipherKeyExchangeType
    CipherKeyExchange_TLS13       -> Bool
    False
            CipherKeyExchangeType
    _                             -> Bool
    True

    storePrivInfoServer :: MonadIO m => Context -> Credential -> m ()
    storePrivInfoServer :: forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
    storePrivInfoServer Context
    ctx (CertificateChain
    cc, PrivKey
    privkey) = m PubKey -> m ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Context -> CertificateChain -> PrivKey -> m PubKey
    forall (m :: * -> *).
    MonadIO m =>
    Context -> CertificateChain -> PrivKey -> m PubKey
    storePrivInfo Context
    ctx CertificateChain
    cc PrivKey
    privkey)

    -- TLS 1.3 or later
    handshakeServerWithTLS13 :: ServerParams
                             -> Context
                             -> Version
                             -> [ExtensionRaw]
                             -> [CipherID]
                             -> Maybe String
                             -> Session
                             -> IO ()
    handshakeServerWithTLS13 :: ServerParams
    -> Context
    -> Version
    -> [ExtensionRaw]
    -> [ExtensionID]
    -> Maybe String
    -> Session
    -> IO ()
    handshakeServerWithTLS13 ServerParams
    sparams Context
    ctx Version
    chosenVersion [ExtensionRaw]
    exts [ExtensionID]
    clientCiphers Maybe String
    _serverName Session
    clientSession = do
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ((ExtensionRaw -> Bool) -> [ExtensionRaw] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (\(ExtensionRaw ExtensionID
    eid ByteString
    _) -> ExtensionID
    eid ExtensionID -> ExtensionID -> Bool
    forall a. Eq a => a -> a -> Bool
    == ExtensionID
    extensionID_PreSharedKey) ([ExtensionRaw] -> Bool) -> [ExtensionRaw] -> Bool
    forall a b. (a -> b) -> a -> b
    $ [ExtensionRaw] -> [ExtensionRaw]
    forall a. HasCallStack => [a] -> [a]
    init [ExtensionRaw]
    exts) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "extension pre_shared_key must be last", Bool
    True, AlertDescription
    IllegalParameter)
        -- Deciding cipher.
        -- The shared cipherlist can become empty after filtering for compatible
        -- creds, check now before calling onCipherChoosing, which does not handle
        -- empty lists.
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Cipher] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Cipher]
    ciphersFilteredVersion) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no cipher in common with the client", Bool
    True, AlertDescription
    HandshakeFailure)
        let usedCipher :: Cipher
    usedCipher = ServerHooks -> Version -> [Cipher] -> Cipher
    onCipherChoosing (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams) Version
    chosenVersion [Cipher]
    ciphersFilteredVersion
            usedHash :: Hash
    usedHash = Cipher -> Hash
    cipherHash Cipher
    usedCipher
            rtt0 :: Bool
    rtt0 = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_EarlyData [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe EarlyDataIndication)
    -> Maybe EarlyDataIndication
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe EarlyDataIndication
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
                     Just (EarlyDataIndication Maybe Word32
    _) -> Bool
    True
                     Maybe EarlyDataIndication
    Nothing                      -> Bool
    False
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    rtt0 (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            -- mark a 0-RTT attempt before a possible HRR, and before updating the
            -- status again if 0-RTT successful
            Context -> Established -> IO ()
    setEstablished Context
    ctx (Int -> Established
    EarlyDataNotAllowed Int
    3) -- hardcoding
        -- Deciding key exchange from key shares
        [KeyShareEntry]
    keyShares <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_KeyShare [ExtensionRaw]
    exts of
              Maybe ByteString
    Nothing -> TLSError -> IO [KeyShareEntry]
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO [KeyShareEntry]) -> TLSError -> IO [KeyShareEntry]
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "key exchange not implemented, expected key_share extension", Bool
    True, AlertDescription
    MissingExtension)
              Just ByteString
    kss -> case MessageType -> ByteString -> Maybe KeyShare
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello ByteString
    kss of
                Just (KeyShareClientHello [KeyShareEntry]
    kses) -> [KeyShareEntry] -> IO [KeyShareEntry]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [KeyShareEntry]
    kses
                Just KeyShare
    _                          -> String -> IO [KeyShareEntry]
    forall a. HasCallStack => String -> a
    error String
    "handshakeServerWithTLS13: invalid KeyShare value"
                Maybe KeyShare
    _                               -> TLSError -> IO [KeyShareEntry]
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO [KeyShareEntry]) -> TLSError -> IO [KeyShareEntry]
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "broken key_share", Bool
    True, AlertDescription
    DecodeError)
        Maybe KeyShareEntry
    mshare <- [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
    findKeyShare [KeyShareEntry]
    keyShares [Group]
    serverGroups
        case Maybe KeyShareEntry
    mshare of
          Maybe KeyShareEntry
    Nothing -> ServerParams
    -> Context
    -> Version
    -> Cipher
    -> [ExtensionRaw]
    -> [Group]
    -> Session
    -> IO ()
    helloRetryRequest ServerParams
    sparams Context
    ctx Version
    chosenVersion Cipher
    usedCipher [ExtensionRaw]
    exts [Group]
    serverGroups Session
    clientSession
          Just KeyShareEntry
    keyShare -> ServerParams
    -> Context
    -> Version
    -> Cipher
    -> [ExtensionRaw]
    -> Hash
    -> KeyShareEntry
    -> Session
    -> Bool
    -> IO ()
    doHandshake13 ServerParams
    sparams Context
    ctx Version
    chosenVersion Cipher
    usedCipher [ExtensionRaw]
    exts Hash
    usedHash KeyShareEntry
    keyShare Session
    clientSession Bool
    rtt0
      where
        ciphersFilteredVersion :: [Cipher]
    ciphersFilteredVersion = (Cipher -> Bool) -> [Cipher] -> [Cipher]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((ExtensionID -> [ExtensionID] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ExtensionID]
    clientCiphers) (ExtensionID -> Bool) -> (Cipher -> ExtensionID) -> Cipher -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Cipher -> ExtensionID
    cipherID) [Cipher]
    serverCiphers
        serverCiphers :: [Cipher]
    serverCiphers = (Cipher -> Bool) -> [Cipher] -> [Cipher]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Version -> Cipher -> Bool
    cipherAllowedForVersion Version
    chosenVersion) (Supported -> [Cipher]
    supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams)
        serverGroups :: [Group]
    serverGroups = Supported -> [Group]
    supportedGroups (Context -> Supported
    ctxSupported Context
    ctx)

    findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
    findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)
    findKeyShare [KeyShareEntry]
    ks [Group]
    ggs = [Group] -> IO (Maybe KeyShareEntry)
    forall {m :: * -> *}.
    MonadIO m =>
    [Group] -> m (Maybe KeyShareEntry)
    go [Group]
    ggs
      where
        go :: [Group] -> m (Maybe KeyShareEntry)
    go []     = Maybe KeyShareEntry -> m (Maybe KeyShareEntry)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe KeyShareEntry
    forall a. Maybe a
    Nothing
        go (Group
    g:[Group]
    gs) = case (KeyShareEntry -> Bool) -> [KeyShareEntry] -> [KeyShareEntry]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Group -> KeyShareEntry -> Bool
    grpEq Group
    g) [KeyShareEntry]
    ks of
          []  -> [Group] -> m (Maybe KeyShareEntry)
    go [Group]
    gs
          [KeyShareEntry
    k] -> do
              Bool -> m () -> m ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (KeyShareEntry -> Bool
    checkKeyShareKeyLength KeyShareEntry
    k) (m () -> m ()) -> m () -> m ()
    forall a b. (a -> b) -> a -> b
    $
                  TLSError -> m ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m ()) -> TLSError -> m ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "broken key_share", Bool
    True, AlertDescription
    IllegalParameter)
              Maybe KeyShareEntry -> m (Maybe KeyShareEntry)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe KeyShareEntry -> m (Maybe KeyShareEntry))
    -> Maybe KeyShareEntry -> m (Maybe KeyShareEntry)
    forall a b. (a -> b) -> a -> b
    $ KeyShareEntry -> Maybe KeyShareEntry
    forall a. a -> Maybe a
    Just KeyShareEntry
    k
          [KeyShareEntry]
    _   -> TLSError -> m (Maybe KeyShareEntry)
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m (Maybe KeyShareEntry))
    -> TLSError -> m (Maybe KeyShareEntry)
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "duplicated key_share", Bool
    True, AlertDescription
    IllegalParameter)
        grpEq :: Group -> KeyShareEntry -> Bool
    grpEq Group
    g KeyShareEntry
    ent = Group
    g Group -> Group -> Bool
    forall a. Eq a => a -> a -> Bool
    == KeyShareEntry -> Group
    keyShareEntryGroup KeyShareEntry
    ent

    doHandshake13 :: ServerParams -> Context -> Version
                  -> Cipher -> [ExtensionRaw]
                  -> Hash -> KeyShareEntry
                  -> Session -> Bool
                  -> IO ()
    doHandshake13 :: ServerParams
    -> Context
    -> Version
    -> Cipher
    -> [ExtensionRaw]
    -> Hash
    -> KeyShareEntry
    -> Session
    -> Bool
    -> IO ()
    doHandshake13 ServerParams
    sparams Context
    ctx Version
    chosenVersion Cipher
    usedCipher [ExtensionRaw]
    exts Hash
    usedHash KeyShareEntry
    clientKeyShare Session
    clientSession Bool
    rtt0 = do
        Context -> IO Session
    newSession Context
    ctx IO Session -> (Session -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= \Session
    ss -> Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            Session -> Bool -> TLSSt ()
    setSession Session
    ss Bool
    False
            Bool -> TLSSt ()
    setClientSupportsPHA Bool
    supportsPHA
        Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Group -> HandshakeM ()
    setNegotiatedGroup (Group -> HandshakeM ()) -> Group -> HandshakeM ()
    forall a b. (a -> b) -> a -> b
    $ KeyShareEntry -> Group
    keyShareEntryGroup KeyShareEntry
    clientKeyShare
        ServerRandom
    srand <- IO ServerRandom
    setServerParameter
        -- ALPN is used in choosePSK
        [ExtensionRaw]
    protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
    applicationProtocol Context
    ctx [ExtensionRaw]
    exts ServerParams
    sparams
        (ByteString
    psk, Maybe (ByteString, Int, Int)
    binderInfo, Bool
    is0RTTvalid) <- IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    choosePSK
        SecretPair EarlySecret
    earlyKey <- Context
    -> CipherChoice
    -> Either ByteString (BaseSecret EarlySecret)
    -> Bool
    -> IO (SecretPair EarlySecret)
    calculateEarlySecret Context
    ctx CipherChoice
    choice (ByteString -> Either ByteString (BaseSecret EarlySecret)
    forall a b. a -> Either a b
    Left ByteString
    psk) Bool
    True
        let earlySecret :: BaseSecret EarlySecret
    earlySecret = SecretPair EarlySecret -> BaseSecret EarlySecret
    forall a. SecretPair a -> BaseSecret a
    pairBase SecretPair EarlySecret
    earlyKey
            clientEarlySecret :: ClientTrafficSecret EarlySecret
    clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
    forall a. SecretPair a -> ClientTrafficSecret a
    pairClient SecretPair EarlySecret
    earlyKey
        [ExtensionRaw]
    extensions <- BaseSecret EarlySecret
    -> Maybe (ByteString, Int, Int) -> IO [ExtensionRaw]
    forall {b}.
    Integral b =>
    BaseSecret EarlySecret
    -> Maybe (ByteString, b, Int) -> IO [ExtensionRaw]
    checkBinder BaseSecret EarlySecret
    earlySecret Maybe (ByteString, Int, Int)
    binderInfo
        Bool
    hrr <- Context -> TLSSt Bool -> IO Bool
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Bool
    getTLS13HRR
        let authenticated :: Bool
    authenticated = Maybe (ByteString, Int, Int) -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe (ByteString, Int, Int)
    binderInfo
            rtt0OK :: Bool
    rtt0OK = Bool
    authenticated Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    hrr Bool -> Bool -> Bool
    && Bool
    rtt0 Bool -> Bool -> Bool
    && Bool
    rtt0accept Bool -> Bool -> Bool
    && Bool
    is0RTTvalid
        Credentials
    extraCreds <- Context -> TLSSt (Maybe String) -> IO (Maybe String)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe String)
    getClientSNI IO (Maybe String)
    -> (Maybe String -> IO Credentials) -> IO Credentials
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ServerHooks -> Maybe String -> IO Credentials
    onServerNameIndication (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams)
        let allCreds :: Credentials
    allCreds = (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
    isCredentialAllowed Version
    chosenVersion [ExtensionRaw]
    exts) (Credentials -> Credentials) -> Credentials -> Credentials
    forall a b. (a -> b) -> a -> b
    $
                           Credentials
    extraCreds Credentials -> Credentials -> Credentials
    forall a. Monoid a => a -> a -> a
    `mappend` Shared -> Credentials
    sharedCredentials (Context -> Shared
    ctxShared Context
    ctx)
        ----------------------------------------------------------------
        Established
    established <- Context -> IO Established
    ctxEstablished Context
    ctx
        if Established
    established Established -> Established -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Established
    NotEstablished then
             if Bool
    rtt0OK then do
                 Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ HandshakeMode13 -> HandshakeM ()
    setTLS13HandshakeMode HandshakeMode13
    RTT0
                 Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ RTT0Status -> HandshakeM ()
    setTLS13RTT0Status RTT0Status
    RTT0Accepted
               else do
                 Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ HandshakeMode13 -> HandshakeM ()
    setTLS13HandshakeMode HandshakeMode13
    RTT0
                 Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ RTT0Status -> HandshakeM ()
    setTLS13RTT0Status RTT0Status
    RTT0Rejected
           else
             if Bool
    authenticated then
                 Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ HandshakeMode13 -> HandshakeM ()
    setTLS13HandshakeMode HandshakeMode13
    PreSharedKey
               else
                 -- FullHandshake or HelloRetryRequest
                 () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        Maybe (Credential, HashAndSignatureAlgorithm)
    mCredInfo <- if Bool
    authenticated then Maybe (Credential, HashAndSignatureAlgorithm)
    -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Credential, HashAndSignatureAlgorithm)
    forall a. Maybe a
    Nothing else Credentials -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall {m :: * -> *}.
    MonadIO m =>
    Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    decideCredentialInfo Credentials
    allCreds
        (ByteString
    ecdhe,KeyShareEntry
    keyShare) <- Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)
    makeServerKeyShare Context
    ctx KeyShareEntry
    clientKeyShare
        Context -> IO ()
    forall (m :: * -> *). MonadIO m => Context -> m ()
    ensureRecvComplete Context
    ctx
        (ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret, BaseSecret HandshakeSecret
    handSecret) <- Context
    -> (forall {b}.
        Monoid b =>
        PacketFlightM
          b
          (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
    -> IO
         (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
    forall a.
    Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
    runPacketFlight Context
    ctx ((forall {b}.
      Monoid b =>
      PacketFlightM
        b
        (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
     -> IO
          (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
    -> (forall {b}.
        Monoid b =>
        PacketFlightM
          b
          (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
    -> IO
         (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
    forall a b. (a -> b) -> a -> b
    $ do
            KeyShareEntry
    -> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
    forall {b}.
    Monoid b =>
    KeyShareEntry
    -> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
    sendServerHello KeyShareEntry
    keyShare ServerRandom
    srand [ExtensionRaw]
    extensions
            Context -> PacketFlightM b ()
    forall b. Monoid b => Context -> PacketFlightM b ()
    sendChangeCipherSpec13 Context
    ctx
        ----------------------------------------------------------------
            SecretTriple HandshakeSecret
    handKey <- IO (SecretTriple HandshakeSecret)
    -> PacketFlightM b (SecretTriple HandshakeSecret)
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (SecretTriple HandshakeSecret)
     -> PacketFlightM b (SecretTriple HandshakeSecret))
    -> IO (SecretTriple HandshakeSecret)
    -> PacketFlightM b (SecretTriple HandshakeSecret)
    forall a b. (a -> b) -> a -> b
    $ Context
    -> CipherChoice
    -> BaseSecret EarlySecret
    -> ByteString
    -> IO (SecretTriple HandshakeSecret)
    calculateHandshakeSecret Context
    ctx CipherChoice
    choice BaseSecret EarlySecret
    earlySecret ByteString
    ecdhe
            let serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
    serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
    forall a. SecretTriple a -> ServerTrafficSecret a
    triServer SecretTriple HandshakeSecret
    handKey
                clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret = SecretTriple HandshakeSecret -> ClientTrafficSecret HandshakeSecret
    forall a. SecretTriple a -> ClientTrafficSecret a
    triClient SecretTriple HandshakeSecret
    handKey
                handSecret :: BaseSecret HandshakeSecret
    handSecret = SecretTriple HandshakeSecret -> BaseSecret HandshakeSecret
    forall a. SecretTriple a -> BaseSecret a
    triBase SecretTriple HandshakeSecret
    handKey
            IO () -> PacketFlightM b ()
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> PacketFlightM b ()) -> IO () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ do
                if Bool
    rtt0OK Bool -> Bool -> Bool
    && Bool -> Bool
    not (Context -> Bool
    ctxQUICMode Context
    ctx)
                    then Context
    -> Hash -> Cipher -> ClientTrafficSecret EarlySecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setRxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ClientTrafficSecret EarlySecret
    clientEarlySecret
                    else Context
    -> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setRxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret
                Context
    -> Hash -> Cipher -> ServerTrafficSecret HandshakeSecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setTxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ServerTrafficSecret HandshakeSecret
    serverHandshakeSecret
                let mEarlySecInfo :: Maybe EarlySecretInfo
    mEarlySecInfo
                     | Bool
    rtt0OK      = EarlySecretInfo -> Maybe EarlySecretInfo
    forall a. a -> Maybe a
    Just (EarlySecretInfo -> Maybe EarlySecretInfo)
    -> EarlySecretInfo -> Maybe EarlySecretInfo
    forall a b. (a -> b) -> a -> b
    $ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
    EarlySecretInfo Cipher
    usedCipher ClientTrafficSecret EarlySecret
    clientEarlySecret
                     | Bool
    otherwise   = Maybe EarlySecretInfo
    forall a. Maybe a
    Nothing
                    handSecInfo :: HandshakeSecretInfo
    handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
    HandshakeSecretInfo Cipher
    usedCipher (ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret,ServerTrafficSecret HandshakeSecret
    serverHandshakeSecret)
                Context -> ServerState -> IO ()
    contextSync Context
    ctx (ServerState -> IO ()) -> ServerState -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [ExtensionRaw]
    -> Maybe EarlySecretInfo -> HandshakeSecretInfo -> ServerState
    SendServerHello [ExtensionRaw]
    exts Maybe EarlySecretInfo
    mEarlySecInfo HandshakeSecretInfo
    handSecInfo
        ----------------------------------------------------------------
            Bool -> [ExtensionRaw] -> PacketFlightM b ()
    forall {b}.
    Monoid b =>
    Bool -> [ExtensionRaw] -> PacketFlightM b ()
    sendExtensions Bool
    rtt0OK [ExtensionRaw]
    protoExt
            case Maybe (Credential, HashAndSignatureAlgorithm)
    mCredInfo of
                Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing              -> () -> PacketFlightM b ()
    forall a. a -> PacketFlightM b a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just (Credential
    cred, HashAndSignatureAlgorithm
    hashSig) -> Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
    forall {b}.
    Monoid b =>
    Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
    sendCertAndVerify Credential
    cred HashAndSignatureAlgorithm
    hashSig
            let ServerTrafficSecret ByteString
    shs = ServerTrafficSecret HandshakeSecret
    serverHandshakeSecret
            Handshake13
    rawFinished <- Context -> Hash -> ByteString -> PacketFlightM b Handshake13
    forall (m :: * -> *).
    MonadIO m =>
    Context -> Hash -> ByteString -> m Handshake13
    makeFinished Context
    ctx Hash
    usedHash ByteString
    shs
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    rawFinished]
            (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
    -> PacketFlightM
         b (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
    forall a. a -> PacketFlightM b a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret, BaseSecret HandshakeSecret
    handSecret)
        Millisecond
    sfSentTime <- IO Millisecond
    getCurrentTimeFromBase
        ----------------------------------------------------------------
        ByteString
    hChSf <- Context -> IO ByteString
    forall (m :: * -> *). MonadIO m => Context -> m ByteString
    transcriptHash Context
    ctx
        SecretTriple ApplicationSecret
    appKey <- Context
    -> CipherChoice
    -> BaseSecret HandshakeSecret
    -> ByteString
    -> IO (SecretTriple ApplicationSecret)
    calculateApplicationSecret Context
    ctx CipherChoice
    choice BaseSecret HandshakeSecret
    handSecret ByteString
    hChSf
        let clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
    clientApplicationSecret0 = SecretTriple ApplicationSecret
    -> ClientTrafficSecret ApplicationSecret
    forall a. SecretTriple a -> ClientTrafficSecret a
    triClient SecretTriple ApplicationSecret
    appKey
            serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
    serverApplicationSecret0 = SecretTriple ApplicationSecret
    -> ServerTrafficSecret ApplicationSecret
    forall a. SecretTriple a -> ServerTrafficSecret a
    triServer SecretTriple ApplicationSecret
    appKey
            applicationSecret :: BaseSecret ApplicationSecret
    applicationSecret = SecretTriple ApplicationSecret -> BaseSecret ApplicationSecret
    forall a. SecretTriple a -> BaseSecret a
    triBase SecretTriple ApplicationSecret
    appKey
        Context
    -> Hash -> Cipher -> ServerTrafficSecret ApplicationSecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setTxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ServerTrafficSecret ApplicationSecret
    serverApplicationSecret0
        let appSecInfo :: ApplicationSecretInfo
    appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
    ApplicationSecretInfo (ClientTrafficSecret ApplicationSecret
    clientApplicationSecret0,ServerTrafficSecret ApplicationSecret
    serverApplicationSecret0)
        Context -> ServerState -> IO ()
    contextSync Context
    ctx (ServerState -> IO ()) -> ServerState -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ApplicationSecretInfo -> ServerState
    SendServerFinished ApplicationSecretInfo
    appSecInfo
        ----------------------------------------------------------------
        if Bool
    rtt0OK then
            Context -> Established -> IO ()
    setEstablished Context
    ctx (Int -> Established
    EarlyDataAllowed Int
    rtt0max)
          else Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Established
    established Established -> Established -> Bool
    forall a. Eq a => a -> a -> Bool
    == Established
    NotEstablished) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            Context -> Established -> IO ()
    setEstablished Context
    ctx (Int -> Established
    EarlyDataNotAllowed Int
    3) -- hardcoding

        let expectFinished :: ByteString -> Handshake13 -> m ()
    expectFinished ByteString
    hChBeforeCf (Finished13 ByteString
    verifyData) = IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ do
                let ClientTrafficSecret ByteString
    chs = ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret
                Context -> Hash -> ByteString -> ByteString -> ByteString -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
    checkFinished Context
    ctx Hash
    usedHash ByteString
    chs ByteString
    hChBeforeCf ByteString
    verifyData
                Context -> IO ()
    handshakeTerminate13 Context
    ctx
                Context
    -> Hash -> Cipher -> ClientTrafficSecret ApplicationSecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setRxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ClientTrafficSecret ApplicationSecret
    clientApplicationSecret0
                BaseSecret ApplicationSecret -> Millisecond -> IO ()
    sendNewSessionTicket BaseSecret ApplicationSecret
    applicationSecret Millisecond
    sfSentTime
            expectFinished ByteString
    _ Handshake13
    hs = String -> Maybe String -> m ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake13 -> String
    forall a. Show a => a -> String
    show Handshake13
    hs) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "finished 13")

        let expectEndOfEarlyData :: Handshake13 -> IO ()
    expectEndOfEarlyData Handshake13
    EndOfEarlyData13 =
                Context
    -> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
    forall ty.
    TrafficSecret ty =>
    Context -> Hash -> Cipher -> ty -> IO ()
    setRxState Context
    ctx Hash
    usedHash Cipher
    usedCipher ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret
            expectEndOfEarlyData Handshake13
    hs = String -> Maybe String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake13 -> String
    forall a. Show a => a -> String
    show Handshake13
    hs) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "end of early data")

        if Bool -> Bool
    not Bool
    authenticated Bool -> Bool -> Bool
    && ServerParams -> Bool
    serverWantClientCert ServerParams
    sparams then
            RecvHandshake13M IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
    runRecvHandshake13 (RecvHandshake13M IO () -> IO ())
    -> RecvHandshake13M IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
              Bool
    skip <- Context
    -> (Handshake13 -> RecvHandshake13M IO Bool)
    -> RecvHandshake13M IO Bool
    forall (m :: * -> *) a.
    MonadIO m =>
    Context
    -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
    recvHandshake13 Context
    ctx Handshake13 -> RecvHandshake13M IO Bool
    expectCertificate
              Bool -> RecvHandshake13M IO () -> RecvHandshake13M IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless Bool
    skip (RecvHandshake13M IO () -> RecvHandshake13M IO ())
    -> RecvHandshake13M IO () -> RecvHandshake13M IO ()
    forall a b. (a -> b) -> a -> b
    $ Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M IO ())
    -> RecvHandshake13M IO ()
    forall (m :: * -> *) a.
    MonadIO m =>
    Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M m a)
    -> RecvHandshake13M m a
    recvHandshake13hash Context
    ctx (ServerParams
    -> Context -> ByteString -> Handshake13 -> RecvHandshake13M IO ()
    forall (m :: * -> *).
    MonadIO m =>
    ServerParams -> Context -> ByteString -> Handshake13 -> m ()
    expectCertVerify ServerParams
    sparams Context
    ctx)
              Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M IO ())
    -> RecvHandshake13M IO ()
    forall (m :: * -> *) a.
    MonadIO m =>
    Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M m a)
    -> RecvHandshake13M m a
    recvHandshake13hash Context
    ctx ByteString -> Handshake13 -> RecvHandshake13M IO ()
    forall {m :: * -> *}.
    MonadIO m =>
    ByteString -> Handshake13 -> m ()
    expectFinished
              Context -> RecvHandshake13M IO ()
    forall (m :: * -> *). MonadIO m => Context -> m ()
    ensureRecvComplete Context
    ctx
          else if Bool
    rtt0OK Bool -> Bool -> Bool
    && Bool -> Bool
    not (Context -> Bool
    ctxQUICMode Context
    ctx) then
            Context -> [PendingAction] -> IO ()
    setPendingActions Context
    ctx [Bool -> (Handshake13 -> IO ()) -> PendingAction
    PendingAction Bool
    True Handshake13 -> IO ()
    expectEndOfEarlyData
                                  ,Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
    PendingActionHash Bool
    True ByteString -> Handshake13 -> IO ()
    forall {m :: * -> *}.
    MonadIO m =>
    ByteString -> Handshake13 -> m ()
    expectFinished]
          else
            RecvHandshake13M IO () -> IO ()
    forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
    runRecvHandshake13 (RecvHandshake13M IO () -> IO ())
    -> RecvHandshake13M IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
              Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M IO ())
    -> RecvHandshake13M IO ()
    forall (m :: * -> *) a.
    MonadIO m =>
    Context
    -> (ByteString -> Handshake13 -> RecvHandshake13M m a)
    -> RecvHandshake13M m a
    recvHandshake13hash Context
    ctx ByteString -> Handshake13 -> RecvHandshake13M IO ()
    forall {m :: * -> *}.
    MonadIO m =>
    ByteString -> Handshake13 -> m ()
    expectFinished
              Context -> RecvHandshake13M IO ()
    forall (m :: * -> *). MonadIO m => Context -> m ()
    ensureRecvComplete Context
    ctx
      where
        choice :: CipherChoice
    choice = Version -> Cipher -> CipherChoice
    makeCipherChoice Version
    chosenVersion Cipher
    usedCipher

        setServerParameter :: IO ServerRandom
    setServerParameter = do
            ServerRandom
    srand <- Context -> Version -> [Version] -> IO ServerRandom
    serverRandom Context
    ctx Version
    chosenVersion ([Version] -> IO ServerRandom) -> [Version] -> IO ServerRandom
    forall a b. (a -> b) -> a -> b
    $ Supported -> [Version]
    supportedVersions (Supported -> [Version]) -> Supported -> [Version]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams
            Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Version -> TLSSt ()
    setVersion Version
    chosenVersion
            IO (Either TLSError ()) -> IO ()
    forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
    failOnEitherError (IO (Either TLSError ()) -> IO ())
    -> IO (Either TLSError ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context
    -> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM (Either TLSError ()) -> IO (Either TLSError ()))
    -> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
    forall a b. (a -> b) -> a -> b
    $ Cipher -> HandshakeM (Either TLSError ())
    setHelloParameters13 Cipher
    usedCipher
            ServerRandom -> IO ServerRandom
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ServerRandom
    srand

        supportsPHA :: Bool
    supportsPHA = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_PostHandshakeAuth [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe PostHandshakeAuth)
    -> Maybe PostHandshakeAuth
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe PostHandshakeAuth
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
            Just PostHandshakeAuth
    PostHandshakeAuth -> Bool
    True
            Maybe PostHandshakeAuth
    Nothing                -> Bool
    False

        choosePSK :: IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    choosePSK = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_PreSharedKey [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe PreSharedKey) -> Maybe PreSharedKey
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe PreSharedKey
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
          Just (PreSharedKeyClientHello (PskIdentity ByteString
    sessionId Word32
    obfAge:[PskIdentity]
    _) bnds :: [ByteString]
    bnds@(ByteString
    bnd:[ByteString]
    _)) -> do
              Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([PskKexMode] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [PskKexMode]
    dhModes) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                  TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no psk_key_exchange_modes extension", Bool
    True, AlertDescription
    MissingExtension)
              if PskKexMode
    PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [PskKexMode]
    dhModes then do
                  let len :: Int
    len = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((ByteString -> Int) -> [ByteString] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (\ByteString
    x -> ByteString -> Int
    B.length ByteString
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) [ByteString]
    bnds) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    2
                      mgr :: SessionManager
    mgr = Shared -> SessionManager
    sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Shared
    serverShared ServerParams
    sparams
                  Maybe SessionData
    msdata <- if Bool
    rtt0 then SessionManager -> ByteString -> IO (Maybe SessionData)
    sessionResumeOnlyOnce SessionManager
    mgr ByteString
    sessionId
                                    else SessionManager -> ByteString -> IO (Maybe SessionData)
    sessionResume SessionManager
    mgr ByteString
    sessionId
                  case Maybe SessionData
    msdata of
                    Just SessionData
    sdata -> do
                        let Just TLS13TicketInfo
    tinfo = SessionData -> Maybe TLS13TicketInfo
    sessionTicketInfo SessionData
    sdata
                            psk :: ByteString
    psk = SessionData -> ByteString
    sessionSecret SessionData
    sdata
                        Bool
    isFresh <- TLS13TicketInfo -> Word32 -> IO Bool
    checkFreshness TLS13TicketInfo
    tinfo Word32
    obfAge
                        (Bool
    isPSKvalid, Bool
    is0RTTvalid) <- SessionData -> IO (Bool, Bool)
    checkSessionEquality SessionData
    sdata
                        if Bool
    isPSKvalid Bool -> Bool -> Bool
    && Bool
    isFresh then
                            (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    psk, (ByteString, Int, Int) -> Maybe (ByteString, Int, Int)
    forall a. a -> Maybe a
    Just (ByteString
    bnd,Int
    0::Int,Int
    len),Bool
    is0RTTvalid)
                          else
                            -- fall back to full handshake
                            (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)
                    Maybe SessionData
    _      -> (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)
                  else (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)
          Maybe PreSharedKey
    _ -> (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)

        checkSessionEquality :: SessionData -> IO (Bool, Bool)
    checkSessionEquality SessionData
    sdata = do
            Maybe String
    msni <- Context -> TLSSt (Maybe String) -> IO (Maybe String)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe String)
    getClientSNI
            Maybe ByteString
    malpn <- Context -> TLSSt (Maybe ByteString) -> IO (Maybe ByteString)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe ByteString)
    getNegotiatedProtocol
            let isSameSNI :: Bool
    isSameSNI = SessionData -> Maybe String
    sessionClientSNI SessionData
    sdata Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe String
    msni
                isSameCipher :: Bool
    isSameCipher = SessionData -> ExtensionID
    sessionCipher SessionData
    sdata ExtensionID -> ExtensionID -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cipher -> ExtensionID
    cipherID Cipher
    usedCipher
                ciphers :: [Cipher]
    ciphers = Supported -> [Cipher]
    supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams
                isSameKDF :: Bool
    isSameKDF = case (Cipher -> Bool) -> [Cipher] -> Maybe Cipher
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find (\Cipher
    c -> Cipher -> ExtensionID
    cipherID Cipher
    c ExtensionID -> ExtensionID -> Bool
    forall a. Eq a => a -> a -> Bool
    == SessionData -> ExtensionID
    sessionCipher SessionData
    sdata) [Cipher]
    ciphers of
                    Maybe Cipher
    Nothing -> Bool
    False
                    Just Cipher
    c  -> Cipher -> Hash
    cipherHash Cipher
    c Hash -> Hash -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cipher -> Hash
    cipherHash Cipher
    usedCipher
                isSameVersion :: Bool
    isSameVersion = Version
    chosenVersion Version -> Version -> Bool
    forall a. Eq a => a -> a -> Bool
    == SessionData -> Version
    sessionVersion SessionData
    sdata
                isSameALPN :: Bool
    isSameALPN = SessionData -> Maybe ByteString
    sessionALPN SessionData
    sdata Maybe ByteString -> Maybe ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe ByteString
    malpn
                isPSKvalid :: Bool
    isPSKvalid = Bool
    isSameKDF Bool -> Bool -> Bool
    && Bool
    isSameSNI -- fixme: SNI is not required
                is0RTTvalid :: Bool
    is0RTTvalid = Bool
    isSameVersion Bool -> Bool -> Bool
    && Bool
    isSameCipher Bool -> Bool -> Bool
    && Bool
    isSameALPN
            (Bool, Bool) -> IO (Bool, Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    isPSKvalid, Bool
    is0RTTvalid)

        rtt0max :: Int
    rtt0max = Int -> Int
    forall a. (Num a, Ord a, FiniteBits a) => a -> a
    safeNonNegative32 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Int
    serverEarlyDataSize ServerParams
    sparams
        rtt0accept :: Bool
    rtt0accept = ServerParams -> Int
    serverEarlyDataSize ServerParams
    sparams Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0

        checkBinder :: BaseSecret EarlySecret
    -> Maybe (ByteString, b, Int) -> IO [ExtensionRaw]
    checkBinder BaseSecret EarlySecret
    _ Maybe (ByteString, b, Int)
    Nothing = [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        checkBinder BaseSecret EarlySecret
    earlySecret (Just (ByteString
    binder,b
    n,Int
    tlen)) = do
            ByteString
    binder' <- Context
    -> BaseSecret EarlySecret
    -> Hash
    -> Int
    -> Maybe ByteString
    -> IO ByteString
    makePSKBinder Context
    ctx BaseSecret EarlySecret
    earlySecret Hash
    usedHash Int
    tlen Maybe ByteString
    forall a. Maybe a
    Nothing
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (ByteString
    binder ByteString -> ByteString -> Bool
    `bytesEq` ByteString
    binder') (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> m a
    decryptError String
    "PSK binder validation failed"
            let selectedIdentity :: ByteString
    selectedIdentity = PreSharedKey -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (PreSharedKey -> ByteString) -> PreSharedKey -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Int -> PreSharedKey
    PreSharedKeyServerHello (Int -> PreSharedKey) -> Int -> PreSharedKey
    forall a b. (a -> b) -> a -> b
    $ b -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral b
    n
            [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_PreSharedKey ByteString
    selectedIdentity]

        decideCredentialInfo :: Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    decideCredentialInfo Credentials
    allCreds = do
            [HashAndSignatureAlgorithm]
    cHashSigs <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_SignatureAlgorithms [ExtensionRaw]
    exts of
                Maybe ByteString
    Nothing -> TLSError -> m [HashAndSignatureAlgorithm]
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m [HashAndSignatureAlgorithm])
    -> TLSError -> m [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no signature_algorithms extension", Bool
    True, AlertDescription
    MissingExtension)
                Just ByteString
    sa -> case MessageType -> ByteString -> Maybe SignatureAlgorithms
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello ByteString
    sa of
                  Maybe SignatureAlgorithms
    Nothing -> TLSError -> m [HashAndSignatureAlgorithm]
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m [HashAndSignatureAlgorithm])
    -> TLSError -> m [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "broken signature_algorithms extension", Bool
    True, AlertDescription
    DecodeError)
                  Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
    sas) -> [HashAndSignatureAlgorithm] -> m [HashAndSignatureAlgorithm]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [HashAndSignatureAlgorithm]
    sas
            -- When deciding signature algorithm and certificate, we try to keep
            -- certificates supported by the client, but fallback to all credentials
            -- if this produces no suitable result (see RFC 5246 section 7.4.2 and
            -- RFC 8446 section 4.4.2.2).
            let sHashSigs :: [HashAndSignatureAlgorithm]
    sHashSigs = (HashAndSignatureAlgorithm -> Bool)
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. (a -> Bool) -> [a] -> [a]
    filter HashAndSignatureAlgorithm -> Bool
    isHashSignatureValid13 ([HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm])
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Supported -> [HashAndSignatureAlgorithm]
    supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
    -> Supported -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx
                hashSigs :: [HashAndSignatureAlgorithm]
    hashSigs = [HashAndSignatureAlgorithm]
    sHashSigs [HashAndSignatureAlgorithm]
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [HashAndSignatureAlgorithm]
    cHashSigs
                cltCreds :: Credentials
    cltCreds = [ExtensionRaw] -> Credentials -> Credentials
    filterCredentialsWithHashSignatures [ExtensionRaw]
    exts Credentials
    allCreds
            case [HashAndSignatureAlgorithm]
    -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 [HashAndSignatureAlgorithm]
    hashSigs Credentials
    cltCreds of
                Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing ->
                    case [HashAndSignatureAlgorithm]
    -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 [HashAndSignatureAlgorithm]
    hashSigs Credentials
    allCreds of
                        Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing -> TLSError -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> m (Maybe (Credential, HashAndSignatureAlgorithm)))
    -> TLSError -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "credential not found", Bool
    True, AlertDescription
    HandshakeFailure)
                        Maybe (Credential, HashAndSignatureAlgorithm)
    mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
    -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Credential, HashAndSignatureAlgorithm)
    mcs
                Maybe (Credential, HashAndSignatureAlgorithm)
    mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
    -> m (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Credential, HashAndSignatureAlgorithm)
    mcs

        sendServerHello :: KeyShareEntry
    -> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
    sendServerHello KeyShareEntry
    keyShare ServerRandom
    srand [ExtensionRaw]
    extensions = do
            let serverKeyShare :: ByteString
    serverKeyShare = KeyShare -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (KeyShare -> ByteString) -> KeyShare -> ByteString
    forall a b. (a -> b) -> a -> b
    $ KeyShareEntry -> KeyShare
    KeyShareServerHello KeyShareEntry
    keyShare
                selectedVersion :: ByteString
    selectedVersion = SupportedVersions -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (SupportedVersions -> ByteString)
    -> SupportedVersions -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Version -> SupportedVersions
    SupportedVersionsServerHello Version
    chosenVersion
                extensions' :: [ExtensionRaw]
    extensions' = ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_KeyShare ByteString
    serverKeyShare
                            ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. a -> [a] -> [a]
    : ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_SupportedVersions ByteString
    selectedVersion
                            ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. a -> [a] -> [a]
    : [ExtensionRaw]
    extensions
                helo :: Handshake13
    helo = ServerRandom
    -> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
    ServerHello13 ServerRandom
    srand Session
    clientSession (Cipher -> ExtensionID
    cipherID Cipher
    usedCipher) [ExtensionRaw]
    extensions'
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    helo]

        sendCertAndVerify :: Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
    sendCertAndVerify cred :: Credential
    cred@(CertificateChain
    certChain, PrivKey
    _) HashAndSignatureAlgorithm
    hashSig = do
            Context -> Credential -> PacketFlightM b ()
    forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
    storePrivInfoServer Context
    ctx Credential
    cred
            Bool -> PacketFlightM b () -> PacketFlightM b ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ServerParams -> Bool
    serverWantClientCert ServerParams
    sparams) (PacketFlightM b () -> PacketFlightM b ())
    -> PacketFlightM b () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ do
                let certReqCtx :: ByteString
    certReqCtx = ByteString
    "" -- this must be zero length here.
                    certReq :: Handshake13
    certReq = ServerParams -> Context -> ByteString -> Handshake13
    makeCertRequest ServerParams
    sparams Context
    ctx ByteString
    certReqCtx
                Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    certReq]
                Context -> HandshakeM () -> PacketFlightM b ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> PacketFlightM b ())
    -> HandshakeM () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> HandshakeM ()
    setCertReqSent Bool
    True

            let CertificateChain [SignedExact Certificate]
    cs = CertificateChain
    certChain
                ess :: [[a]]
    ess = Int -> [a] -> [[a]]
    forall a. Int -> a -> [a]
    replicate ([SignedExact Certificate] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [SignedExact Certificate]
    cs) []
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [ByteString -> CertificateChain -> [[ExtensionRaw]] -> Handshake13
    Certificate13 ByteString
    "" CertificateChain
    certChain [[ExtensionRaw]]
    forall {a}. [[a]]
    ess]
            ByteString
    hChSc <- Context -> PacketFlightM b ByteString
    forall (m :: * -> *). MonadIO m => Context -> m ByteString
    transcriptHash Context
    ctx
            PubKey
    pubkey <- Context -> PacketFlightM b PubKey
    forall (m :: * -> *). MonadIO m => Context -> m PubKey
    getLocalPublicKey Context
    ctx
            Handshake13
    vrfy <- Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> ByteString
    -> PacketFlightM b Handshake13
    forall (m :: * -> *).
    MonadIO m =>
    Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> ByteString
    -> m Handshake13
    makeCertVerify Context
    ctx PubKey
    pubkey HashAndSignatureAlgorithm
    hashSig ByteString
    hChSc
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    vrfy]

        sendExtensions :: Bool -> [ExtensionRaw] -> PacketFlightM b ()
    sendExtensions Bool
    rtt0OK [ExtensionRaw]
    protoExt = do
            Maybe String
    msni <- IO (Maybe String) -> PacketFlightM b (Maybe String)
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Maybe String) -> PacketFlightM b (Maybe String))
    -> IO (Maybe String) -> PacketFlightM b (Maybe String)
    forall a b. (a -> b) -> a -> b
    $ Context -> TLSSt (Maybe String) -> IO (Maybe String)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe String)
    getClientSNI
            let sniExtension :: Maybe ExtensionRaw
    sniExtension = case Maybe String
    msni of
                  -- RFC6066: In this event, the server SHALL include
                  -- an extension of type "server_name" in the
                  -- (extended) server hello. The "extension_data"
                  -- field of this extension SHALL be empty.
                  Just String
    _  -> ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_ServerName ByteString
    ""
                  Maybe String
    Nothing -> Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
            Maybe Group
    mgroup <- Context
    -> HandshakeM (Maybe Group) -> PacketFlightM b (Maybe Group)
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx HandshakeM (Maybe Group)
    getNegotiatedGroup
            let serverGroups :: [Group]
    serverGroups = Supported -> [Group]
    supportedGroups (Context -> Supported
    ctxSupported Context
    ctx)
                groupExtension :: Maybe ExtensionRaw
    groupExtension
                  | [Group] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Group]
    serverGroups = Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
                  | Bool -> (Group -> Bool) -> Maybe Group -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    True (Group -> Group -> Bool
    forall a. Eq a => a -> a -> Bool
    == [Group] -> Group
    forall a. HasCallStack => [a] -> a
    head [Group]
    serverGroups) Maybe Group
    mgroup = Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
                  | Bool
    otherwise = ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_NegotiatedGroups (ByteString -> ExtensionRaw) -> ByteString -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ NegotiatedGroups -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode ([Group] -> NegotiatedGroups
    NegotiatedGroups [Group]
    serverGroups)
            let earlyDataExtension :: Maybe ExtensionRaw
    earlyDataExtension
                  | Bool
    rtt0OK = ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_EarlyData (ByteString -> ExtensionRaw) -> ByteString -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ EarlyDataIndication -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (Maybe Word32 -> EarlyDataIndication
    EarlyDataIndication Maybe Word32
    forall a. Maybe a
    Nothing)
                  | Bool
    otherwise = Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
            let extensions :: [ExtensionRaw]
    extensions = Shared -> [ExtensionRaw]
    sharedHelloExtensions (ServerParams -> Shared
    serverShared ServerParams
    sparams)
                          [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [Maybe ExtensionRaw] -> [ExtensionRaw]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe ExtensionRaw
    earlyDataExtension
                                       ,Maybe ExtensionRaw
    groupExtension
                                       ,Maybe ExtensionRaw
    sniExtension
                                       ]
                          [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [ExtensionRaw]
    protoExt
            [ExtensionRaw]
    extensions' <- IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw]
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw])
    -> IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw]
    forall a b. (a -> b) -> a -> b
    $ ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
    onEncryptedExtensionsCreating (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams) [ExtensionRaw]
    extensions
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [[ExtensionRaw] -> Handshake13
    EncryptedExtensions13 [ExtensionRaw]
    extensions']

        sendNewSessionTicket :: BaseSecret ApplicationSecret -> Millisecond -> IO ()
    sendNewSessionTicket BaseSecret ApplicationSecret
    applicationSecret Millisecond
    sfSentTime = Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    sendNST (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            Millisecond
    cfRecvTime <- IO Millisecond
    getCurrentTimeFromBase
            let rtt :: Millisecond
    rtt = Millisecond
    cfRecvTime Millisecond -> Millisecond -> Millisecond
    forall a. Num a => a -> a -> a
    - Millisecond
    sfSentTime
            ByteString
    nonce <- Context -> Int -> IO ByteString
    getStateRNG Context
    ctx Int
    32
            BaseSecret ResumptionSecret
    resumptionMasterSecret <- Context
    -> CipherChoice
    -> BaseSecret ApplicationSecret
    -> IO (BaseSecret ResumptionSecret)
    calculateResumptionSecret Context
    ctx CipherChoice
    choice BaseSecret ApplicationSecret
    applicationSecret
            let life :: Word32
    life = Int -> Word32
    forall {a} {a}. (Num a, Integral a) => a -> a
    toSeconds (Int -> Word32) -> Int -> Word32
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Int
    serverTicketLifetime ServerParams
    sparams
                psk :: ByteString
    psk = CipherChoice
    -> BaseSecret ResumptionSecret -> ByteString -> ByteString
    derivePSK CipherChoice
    choice BaseSecret ResumptionSecret
    resumptionMasterSecret ByteString
    nonce
            (ByteString
    label, Word32
    add) <- Word32
    -> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
    generateSession Word32
    life ByteString
    psk Int
    rtt0max Millisecond
    rtt
            let nst :: Handshake13
    nst = Word32 -> Word32 -> ByteString -> ByteString -> Int -> Handshake13
    forall {p}.
    Integral p =>
    Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
    createNewSessionTicket Word32
    life Word32
    add ByteString
    nonce ByteString
    label Int
    rtt0max
            Context -> Packet13 -> IO ()
    sendPacket13 Context
    ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    nst]
          where
            sendNST :: Bool
    sendNST = PskKexMode
    PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [PskKexMode]
    dhModes
            generateSession :: Word32
    -> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
    generateSession Word32
    life ByteString
    psk Int
    maxSize Millisecond
    rtt = do
                Session (Just ByteString
    sessionId) <- Context -> IO Session
    newSession Context
    ctx
                TLS13TicketInfo
    tinfo <- Word32
    -> Either Context Word32 -> Maybe Millisecond -> IO TLS13TicketInfo
    createTLS13TicketInfo Word32
    life (Context -> Either Context Word32
    forall a b. a -> Either a b
    Left Context
    ctx) (Millisecond -> Maybe Millisecond
    forall a. a -> Maybe a
    Just Millisecond
    rtt)
                SessionData
    sdata <- Context
    -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
    getSessionData13 Context
    ctx Cipher
    usedCipher TLS13TicketInfo
    tinfo Int
    maxSize ByteString
    psk
                let mgr :: SessionManager
    mgr = Shared -> SessionManager
    sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Shared
    serverShared ServerParams
    sparams
                SessionManager -> ByteString -> SessionData -> IO ()
    sessionEstablish SessionManager
    mgr ByteString
    sessionId SessionData
    sdata
                (ByteString, Word32) -> IO (ByteString, Word32)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    sessionId, TLS13TicketInfo -> Word32
    ageAdd TLS13TicketInfo
    tinfo)
            createNewSessionTicket :: Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
    createNewSessionTicket Word32
    life Word32
    add ByteString
    nonce ByteString
    label p
    maxSize =
                Word32
    -> Word32
    -> ByteString
    -> ByteString
    -> [ExtensionRaw]
    -> Handshake13
    NewSessionTicket13 Word32
    life Word32
    add ByteString
    nonce ByteString
    label [ExtensionRaw]
    extensions
              where
                tedi :: ByteString
    tedi = EarlyDataIndication -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (EarlyDataIndication -> ByteString)
    -> EarlyDataIndication -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Maybe Word32 -> EarlyDataIndication
    EarlyDataIndication (Maybe Word32 -> EarlyDataIndication)
    -> Maybe Word32 -> EarlyDataIndication
    forall a b. (a -> b) -> a -> b
    $ Word32 -> Maybe Word32
    forall a. a -> Maybe a
    Just (Word32 -> Maybe Word32) -> Word32 -> Maybe Word32
    forall a b. (a -> b) -> a -> b
    $ p -> Word32
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral p
    maxSize
                extensions :: [ExtensionRaw]
    extensions = [ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_EarlyData ByteString
    tedi]
            toSeconds :: a -> a
    toSeconds a
    i | a
    i a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    < a
    0      = a
    0
                        | a
    i a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    > a
    604800 = a
    604800
                        | Bool
    otherwise  = a -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral a
    i

        dhModes :: [PskKexMode]
    dhModes = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_PskKeyExchangeModes [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe PskKeyExchangeModes)
    -> Maybe PskKeyExchangeModes
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe PskKeyExchangeModes
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
          Just (PskKeyExchangeModes [PskKexMode]
    ms) -> [PskKexMode]
    ms
          Maybe PskKeyExchangeModes
    Nothing                       -> []

        expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
        expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
    expectCertificate (Certificate13 ByteString
    certCtx CertificateChain
    certs [[ExtensionRaw]]
    _ext) = IO Bool -> RecvHandshake13M IO Bool
    forall a. IO a -> RecvHandshake13M IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> RecvHandshake13M IO Bool)
    -> IO Bool -> RecvHandshake13M IO Bool
    forall a b. (a -> b) -> a -> b
    $ do
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString
    certCtx ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    /= ByteString
    "") (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "certificate request context MUST be empty", Bool
    True, AlertDescription
    IllegalParameter)
            -- fixme checking _ext
            ServerParams -> Context -> CertificateChain -> IO ()
    clientCertificate ServerParams
    sparams Context
    ctx CertificateChain
    certs
            Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> IO Bool) -> Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ CertificateChain -> Bool
    isNullCertificateChain CertificateChain
    certs
        expectCertificate Handshake13
    hs = String -> Maybe String -> RecvHandshake13M IO Bool
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake13 -> String
    forall a. Show a => a -> String
    show Handshake13
    hs) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "certificate 13")

        hashSize :: Int
    hashSize = Hash -> Int
    hashDigestSize Hash
    usedHash
        zero :: ByteString
    zero = Int -> CompressionID -> ByteString
    B.replicate Int
    hashSize CompressionID
    0

    expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
    expectCertVerify :: forall (m :: * -> *).
    MonadIO m =>
    ServerParams -> Context -> ByteString -> Handshake13 -> m ()
    expectCertVerify ServerParams
    sparams Context
    ctx ByteString
    hChCc (CertVerify13 HashAndSignatureAlgorithm
    sigAlg ByteString
    sig) = IO () -> m ()
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ do
        certs :: CertificateChain
    certs@(CertificateChain [SignedExact Certificate]
    cc) <- Context -> String -> IO CertificateChain
    forall (m :: * -> *).
    MonadIO m =>
    Context -> String -> m CertificateChain
    checkValidClientCertChain Context
    ctx String
    "finished 13 message expected"
        PubKey
    pubkey <- case [SignedExact Certificate]
    cc of
                    [] -> TLSError -> IO PubKey
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO PubKey) -> TLSError -> IO PubKey
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "client certificate missing", Bool
    True, AlertDescription
    HandshakeFailure)
                    SignedExact Certificate
    c:[SignedExact Certificate]
    _ -> PubKey -> IO PubKey
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (PubKey -> IO PubKey) -> PubKey -> IO PubKey
    forall a b. (a -> b) -> a -> b
    $ Certificate -> PubKey
    certPubKey (Certificate -> PubKey) -> Certificate -> PubKey
    forall a b. (a -> b) -> a -> b
    $ SignedExact Certificate -> Certificate
    getCertificate SignedExact Certificate
    c
        Version
    ver <- Context -> TLSSt Version -> IO Version
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Version
    getVersion
        Version -> PubKey -> IO ()
    forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
    checkDigitalSignatureKey Version
    ver PubKey
    pubkey
        Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ PubKey -> HandshakeM ()
    setPublicKey PubKey
    pubkey
        Bool
    verif <- Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> ByteString
    -> ByteString
    -> IO Bool
    forall (m :: * -> *).
    MonadIO m =>
    Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> ByteString
    -> ByteString
    -> m Bool
    checkCertVerify Context
    ctx PubKey
    pubkey HashAndSignatureAlgorithm
    sigAlg ByteString
    sig ByteString
    hChCc
        ServerParams -> Context -> CertificateChain -> Bool -> IO ()
    clientCertVerify ServerParams
    sparams Context
    ctx CertificateChain
    certs Bool
    verif
    expectCertVerify ServerParams
    _ Context
    _ ByteString
    _ Handshake13
    hs = String -> Maybe String -> m ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake13 -> String
    forall a. Show a => a -> String
    show Handshake13
    hs) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "certificate verify 13")

    helloRetryRequest :: ServerParams -> Context -> Version -> Cipher -> [ExtensionRaw] -> [Group] -> Session -> IO ()
    helloRetryRequest :: ServerParams
    -> Context
    -> Version
    -> Cipher
    -> [ExtensionRaw]
    -> [Group]
    -> Session
    -> IO ()
    helloRetryRequest ServerParams
    sparams Context
    ctx Version
    chosenVersion Cipher
    usedCipher [ExtensionRaw]
    exts [Group]
    serverGroups Session
    clientSession = do
        Bool
    twice <- Context -> TLSSt Bool -> IO Bool
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Bool
    getTLS13HRR
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    twice (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "Hello retry not allowed again", Bool
    True, AlertDescription
    HandshakeFailure)
        Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> TLSSt ()
    setTLS13HRR Bool
    True
        IO (Either TLSError ()) -> IO ()
    forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
    failOnEitherError (IO (Either TLSError ()) -> IO ())
    -> IO (Either TLSError ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context
    -> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM (Either TLSError ()) -> IO (Either TLSError ()))
    -> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
    forall a b. (a -> b) -> a -> b
    $ Cipher -> HandshakeM (Either TLSError ())
    setHelloParameters13 Cipher
    usedCipher
        let clientGroups :: [Group]
    clientGroups = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_NegotiatedGroups [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe NegotiatedGroups) -> Maybe NegotiatedGroups
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType -> ByteString -> Maybe NegotiatedGroups
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
              Just (NegotiatedGroups [Group]
    gs) -> [Group]
    gs
              Maybe NegotiatedGroups
    Nothing                    -> []
            possibleGroups :: [Group]
    possibleGroups = [Group]
    serverGroups [Group] -> [Group] -> [Group]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Group]
    clientGroups
        case [Group]
    possibleGroups of
          [] -> TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no group in common with the client for HRR", Bool
    True, AlertDescription
    HandshakeFailure)
          Group
    g:[Group]
    _ -> do
              let serverKeyShare :: ByteString
    serverKeyShare = KeyShare -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (KeyShare -> ByteString) -> KeyShare -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Group -> KeyShare
    KeyShareHRR Group
    g
                  selectedVersion :: ByteString
    selectedVersion = SupportedVersions -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (SupportedVersions -> ByteString)
    -> SupportedVersions -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Version -> SupportedVersions
    SupportedVersionsServerHello Version
    chosenVersion
                  extensions :: [ExtensionRaw]
    extensions = [ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_KeyShare ByteString
    serverKeyShare
                               ,ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_SupportedVersions ByteString
    selectedVersion]
                  hrr :: Handshake13
    hrr = ServerRandom
    -> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
    ServerHello13 ServerRandom
    hrrRandom Session
    clientSession (Cipher -> ExtensionID
    cipherID Cipher
    usedCipher) [ExtensionRaw]
    extensions
              Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ HandshakeMode13 -> HandshakeM ()
    setTLS13HandshakeMode HandshakeMode13
    HelloRetryRequest
              Context -> (forall {b}. Monoid b => PacketFlightM b ()) -> IO ()
    forall a.
    Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
    runPacketFlight Context
    ctx ((forall {b}. Monoid b => PacketFlightM b ()) -> IO ())
    -> (forall {b}. Monoid b => PacketFlightM b ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                    Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    hrr]
                    Context -> PacketFlightM b ()
    forall b. Monoid b => Context -> PacketFlightM b ()
    sendChangeCipherSpec13 Context
    ctx
              ServerParams -> Context -> IO ()
    handshakeServer ServerParams
    sparams Context
    ctx

    findHighestVersionFrom :: Version -> [Version] -> Maybe Version
    findHighestVersionFrom :: Version -> [Version] -> Maybe Version
    findHighestVersionFrom Version
    clientVersion [Version]
    allowedVersions =
        case (Version -> Bool) -> [Version] -> [Version]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Version
    clientVersion Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    >=) ([Version] -> [Version]) -> [Version] -> [Version]
    forall a b. (a -> b) -> a -> b
    $ (Version -> Down Version) -> [Version] -> [Version]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn Version -> Down Version
    forall a. a -> Down a
    Down [Version]
    allowedVersions of
            []  -> Maybe Version
    forall a. Maybe a
    Nothing
            Version
    v:[Version]
    _ -> Version -> Maybe Version
    forall a. a -> Maybe a
    Just Version
    v

    -- We filter our allowed ciphers here according to dynamic credential lists.
    -- Credentials 'creds' come from server parameters but also SNI callback.
    -- When the key exchange requires a signature, we use a
    -- subset of this list named 'sigCreds'.  This list has been filtered in order
    -- to remove certificates that are not compatible with hash/signature
    -- restrictions (TLS 1.2).
    getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
    getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
    getCiphers ServerParams
    sparams Credentials
    creds Credentials
    sigCreds = (Cipher -> Bool) -> [Cipher] -> [Cipher]
    forall a. (a -> Bool) -> [a] -> [a]
    filter Cipher -> Bool
    authorizedCKE (Supported -> [Cipher]
    supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams)
          where authorizedCKE :: Cipher -> Bool
    authorizedCKE Cipher
    cipher =
                    case Cipher -> CipherKeyExchangeType
    cipherKeyExchange Cipher
    cipher of
                        CipherKeyExchangeType
    CipherKeyExchange_RSA         -> Bool
    canEncryptRSA
                        CipherKeyExchangeType
    CipherKeyExchange_DH_Anon     -> Bool
    True
                        CipherKeyExchangeType
    CipherKeyExchange_DHE_RSA     -> Bool
    canSignRSA
                        CipherKeyExchangeType
    CipherKeyExchange_DHE_DSS     -> Bool
    canSignDSS
                        CipherKeyExchangeType
    CipherKeyExchange_ECDHE_RSA   -> Bool
    canSignRSA
                        CipherKeyExchangeType
    CipherKeyExchange_ECDHE_ECDSA -> Bool
    canSignECDSA
                        -- unimplemented: non ephemeral DH & ECDH.
                        -- Note, these *should not* be implemented, and have
                        -- (for example) been removed in OpenSSL 1.1.0
                        --
                        CipherKeyExchangeType
    CipherKeyExchange_DH_DSS      -> Bool
    False
                        CipherKeyExchangeType
    CipherKeyExchange_DH_RSA      -> Bool
    False
                        CipherKeyExchangeType
    CipherKeyExchange_ECDH_ECDSA  -> Bool
    False
                        CipherKeyExchangeType
    CipherKeyExchange_ECDH_RSA    -> Bool
    False
                        CipherKeyExchangeType
    CipherKeyExchange_TLS13       -> Bool
    False -- not reached

                canSignDSS :: Bool
    canSignDSS    = KeyExchangeSignatureAlg
    KX_DSS KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [KeyExchangeSignatureAlg]
    signingAlgs
                canSignRSA :: Bool
    canSignRSA    = KeyExchangeSignatureAlg
    KX_RSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [KeyExchangeSignatureAlg]
    signingAlgs
                canSignECDSA :: Bool
    canSignECDSA  = KeyExchangeSignatureAlg
    KX_ECDSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [KeyExchangeSignatureAlg]
    signingAlgs
                canEncryptRSA :: Bool
    canEncryptRSA = Maybe Credential -> Bool
    forall a. Maybe a -> Bool
    isJust (Maybe Credential -> Bool) -> Maybe Credential -> Bool
    forall a b. (a -> b) -> a -> b
    $ Credentials -> Maybe Credential
    credentialsFindForDecrypting Credentials
    creds
                signingAlgs :: [KeyExchangeSignatureAlg]
    signingAlgs   = Credentials -> [KeyExchangeSignatureAlg]
    credentialsListSigningAlgorithms Credentials
    sigCreds

    findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
    findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
    findHighestVersionFrom13 [Version]
    clientVersions [Version]
    serverVersions = case [Version]
    svs [Version] -> [Version] -> [Version]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [Version]
    cvs of
            []  -> Maybe Version
    forall a. Maybe a
    Nothing
            Version
    v:[Version]
    _ -> Version -> Maybe Version
    forall a. a -> Maybe a
    Just Version
    v
      where
        svs :: [Version]
    svs = (Version -> Down Version) -> [Version] -> [Version]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn Version -> Down Version
    forall a. a -> Down a
    Down [Version]
    serverVersions
        cvs :: [Version]
    cvs = (Version -> Down Version) -> [Version] -> [Version]
    forall b a. Ord b => (a -> b) -> [a] -> [a]
    sortOn Version -> Down Version
    forall a. a -> Down a
    Down ([Version] -> [Version]) -> [Version] -> [Version]
    forall a b. (a -> b) -> a -> b
    $ (Version -> Bool) -> [Version] -> [Version]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Version -> Version -> Bool
    forall a. Ord a => a -> a -> Bool
    > Version
    SSL3) [Version]
    clientVersions

    applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
    applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
    applicationProtocol Context
    ctx [ExtensionRaw]
    exts ServerParams
    sparams = do
        -- ALPN (Application Layer Protocol Negotiation)
        case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
    extensionLookup ExtensionID
    extensionID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
    exts Maybe ByteString
    -> (ByteString -> Maybe ApplicationLayerProtocolNegotiation)
    -> Maybe ApplicationLayerProtocolNegotiation
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MessageType
    -> ByteString -> Maybe ApplicationLayerProtocolNegotiation
    forall a. Extension a => MessageType -> ByteString -> Maybe a
    extensionDecode MessageType
    MsgTClientHello of
            Maybe ApplicationLayerProtocolNegotiation
    Nothing -> [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            Just (ApplicationLayerProtocolNegotiation [ByteString]
    protos) -> do
                case ServerHooks -> Maybe ([ByteString] -> IO ByteString)
    onALPNClientSuggest (ServerHooks -> Maybe ([ByteString] -> IO ByteString))
    -> ServerHooks -> Maybe ([ByteString] -> IO ByteString)
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams of
                    Just [ByteString] -> IO ByteString
    io -> do
                        ByteString
    proto <- [ByteString] -> IO ByteString
    io [ByteString]
    protos
                        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString
    proto ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    "") (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
                            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "no supported application protocols", Bool
    True, AlertDescription
    NoApplicationProtocol)
                        Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                            Bool -> TLSSt ()
    setExtensionALPN Bool
    True
                            ByteString -> TLSSt ()
    setNegotiatedProtocol ByteString
    proto
                        [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ ExtensionID -> ByteString -> ExtensionRaw
    ExtensionRaw ExtensionID
    extensionID_ApplicationLayerProtocolNegotiation
                                                (ApplicationLayerProtocolNegotiation -> ByteString
    forall a. Extension a => a -> ByteString
    extensionEncode (ApplicationLayerProtocolNegotiation -> ByteString)
    -> ApplicationLayerProtocolNegotiation -> ByteString
    forall a b. (a -> b) -> a -> b
    $ [ByteString] -> ApplicationLayerProtocolNegotiation
    ApplicationLayerProtocolNegotiation [ByteString
    proto]) ]
                    Maybe ([ByteString] -> IO ByteString)
    _ -> [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []

    credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]
    -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 [HashAndSignatureAlgorithm]
    hss0 Credentials
    creds = [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop [HashAndSignatureAlgorithm]
    hss0
      where
        loop :: [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop  []       = Maybe (Credential, HashAndSignatureAlgorithm)
    forall a. Maybe a
    Nothing
        loop  (HashAndSignatureAlgorithm
    hs:[HashAndSignatureAlgorithm]
    hss) = case HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' HashAndSignatureAlgorithm
    hs Credentials
    creds of
            Maybe Credential
    Nothing   -> [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop [HashAndSignatureAlgorithm]
    hss
            Just Credential
    cred -> (Credential, HashAndSignatureAlgorithm)
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    forall a. a -> Maybe a
    Just (Credential
    cred, HashAndSignatureAlgorithm
    hs)

    -- See credentialsFindForSigning.
    credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' HashAndSignatureAlgorithm
    sigAlg (Credentials [Credential]
    l) = (Credential -> Bool) -> [Credential] -> Maybe Credential
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find Credential -> Bool
    forSigning [Credential]
    l
      where
        forSigning :: Credential -> Bool
    forSigning Credential
    cred = case Credential -> Maybe PubKey
    credentialDigitalSignatureKey Credential
    cred of
            Maybe PubKey
    Nothing  -> Bool
    False
            Just PubKey
    pub -> PubKey
    pub PubKey -> HashAndSignatureAlgorithm -> Bool
    `signatureCompatible13` HashAndSignatureAlgorithm
    sigAlg

    clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()
    clientCertificate :: ServerParams -> Context -> CertificateChain -> IO ()
    clientCertificate ServerParams
    sparams Context
    ctx CertificateChain
    certs = do
        -- run certificate recv hook
        Context -> (Hooks -> IO ()) -> IO ()
    forall a. Context -> (Hooks -> IO a) -> IO a
    ctxWithHooks Context
    ctx (Hooks -> CertificateChain -> IO ()
    `hookRecvCertificates` CertificateChain
    certs)
        -- Call application callback to see whether the
        -- certificate chain is acceptable.
        --
        CertificateUsage
    usage <- IO CertificateUsage -> IO CertificateUsage
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO CertificateUsage -> IO CertificateUsage)
    -> IO CertificateUsage -> IO CertificateUsage
    forall a b. (a -> b) -> a -> b
    $ IO CertificateUsage
    -> (SomeException -> IO CertificateUsage) -> IO CertificateUsage
    forall a. IO a -> (SomeException -> IO a) -> IO a
    catchException (ServerHooks -> CertificateChain -> IO CertificateUsage
    onClientCertificate (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams) CertificateChain
    certs) SomeException -> IO CertificateUsage
    rejectOnException
        case CertificateUsage
    usage of
            CertificateUsage
    CertificateUsageAccept        -> [ExtKeyUsageFlag] -> CertificateChain -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    [ExtKeyUsageFlag] -> CertificateChain -> m ()
    verifyLeafKeyUsage [ExtKeyUsageFlag
    KeyUsage_digitalSignature] CertificateChain
    certs
            CertificateUsageReject CertificateRejectReason
    reason -> CertificateRejectReason -> IO ()
    forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
    certificateRejected CertificateRejectReason
    reason

        -- Remember cert chain for later use.
        --
        Context -> HandshakeM () -> IO ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ CertificateChain -> HandshakeM ()
    setClientCertChain CertificateChain
    certs

    clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
    clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO ()
    clientCertVerify ServerParams
    sparams Context
    ctx CertificateChain
    certs Bool
    verif = do
        if Bool
    verif then do
            -- When verification succeeds, commit the
            -- client certificate chain to the context.
            --
            Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ CertificateChain -> TLSSt ()
    setClientCertificateChain CertificateChain
    certs
            () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          else do
            -- Either verification failed because of an
            -- invalid format (with an error message), or
            -- the signature is wrong.  In either case,
            -- ask the application if it wants to
            -- proceed, we will do that.
            Bool
    res <- IO Bool -> IO Bool
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ ServerHooks -> IO Bool
    onUnverifiedClientCert (ServerParams -> ServerHooks
    serverHooks ServerParams
    sparams)
            if Bool
    res then do
                    -- When verification fails, but the
                    -- application callbacks accepts, we
                    -- also commit the client certificate
                    -- chain to the context.
                    Context -> TLSSt () -> IO ()
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ CertificateChain -> TLSSt ()
    setClientCertificateChain CertificateChain
    certs
                    else String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> m a
    decryptError String
    "verification failed"

    newCertReqContext :: Context -> IO CertReqContext
    newCertReqContext :: Context -> IO ByteString
    newCertReqContext Context
    ctx = Context -> Int -> IO ByteString
    getStateRNG Context
    ctx Int
    32

    requestCertificateServer :: ServerParams -> Context -> IO Bool
    requestCertificateServer :: ServerParams -> Context -> IO Bool
    requestCertificateServer ServerParams
    sparams Context
    ctx = do
        Bool
    tls13 <- Context -> IO Bool
    forall (m :: * -> *). MonadIO m => Context -> m Bool
    tls13orLater Context
    ctx
        Bool
    supportsPHA <- Context -> TLSSt Bool -> IO Bool
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt Bool
    getClientSupportsPHA
        let ok :: Bool
    ok = Bool
    tls13 Bool -> Bool -> Bool
    && Bool
    supportsPHA
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    ok (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            ByteString
    certReqCtx <- Context -> IO ByteString
    newCertReqContext Context
    ctx
            let certReq :: Handshake13
    certReq = ServerParams -> Context -> ByteString -> Handshake13
    makeCertRequest ServerParams
    sparams Context
    ctx ByteString
    certReqCtx
            IO (Saved (Maybe HandshakeState))
    -> (Saved (Maybe HandshakeState)
        -> IO (Saved (Maybe HandshakeState)))
    -> (Saved (Maybe HandshakeState) -> IO ())
    -> IO ()
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (Context -> IO (Saved (Maybe HandshakeState))
    saveHState Context
    ctx) (Context
    -> Saved (Maybe HandshakeState)
    -> IO (Saved (Maybe HandshakeState))
    restoreHState Context
    ctx) ((Saved (Maybe HandshakeState) -> IO ()) -> IO ())
    -> (Saved (Maybe HandshakeState) -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Saved (Maybe HandshakeState)
    _ -> do
                Context -> Handshake13 -> IO ()
    addCertRequest13 Context
    ctx Handshake13
    certReq
                Context -> Packet13 -> IO ()
    sendPacket13 Context
    ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    certReq]
        Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    ok

    postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
    postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
    postHandshakeAuthServerWith ServerParams
    sparams Context
    ctx h :: Handshake13
    h@(Certificate13 ByteString
    certCtx CertificateChain
    certs [[ExtensionRaw]]
    _ext) = do
        Maybe Handshake13
    mCertReq <- Context -> ByteString -> IO (Maybe Handshake13)
    getCertRequest13 Context
    ctx ByteString
    certCtx
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Maybe Handshake13 -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Handshake13
    mCertReq) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "unknown certificate request context", Bool
    True, AlertDescription
    DecodeError)
        let certReq :: Handshake13
    certReq = String -> Maybe Handshake13 -> Handshake13
    forall a. String -> Maybe a -> a
    fromJust String
    "certReq" Maybe Handshake13
    mCertReq

        -- fixme checking _ext
        ServerParams -> Context -> CertificateChain -> IO ()
    clientCertificate ServerParams
    sparams Context
    ctx CertificateChain
    certs

        Saved (Maybe HandshakeState)
    baseHState <- Context -> IO (Saved (Maybe HandshakeState))
    saveHState Context
    ctx
        Context -> Handshake13 -> IO ()
    processHandshake13 Context
    ctx Handshake13
    certReq
        Context -> Handshake13 -> IO ()
    processHandshake13 Context
    ctx Handshake13
    h

        (Hash
    usedHash, Cipher
    _, CryptLevel
    level, ByteString
    applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
    getRxState Context
    ctx
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (CryptLevel
    level CryptLevel -> CryptLevel -> Bool
    forall a. Eq a => a -> a -> Bool
    == CryptLevel
    CryptApplicationSecret) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
            TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "tried post-handshake authentication without application traffic secret", Bool
    True, AlertDescription
    InternalError)

        let expectFinished :: ByteString -> Handshake13 -> IO ()
    expectFinished ByteString
    hChBeforeCf (Finished13 ByteString
    verifyData) = do
                Context -> Hash -> ByteString -> ByteString -> ByteString -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
    checkFinished Context
    ctx Hash
    usedHash ByteString
    applicationSecretN ByteString
    hChBeforeCf ByteString
    verifyData
                IO (Saved (Maybe HandshakeState)) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO (Saved (Maybe HandshakeState)) -> IO ())
    -> IO (Saved (Maybe HandshakeState)) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Context
    -> Saved (Maybe HandshakeState)
    -> IO (Saved (Maybe HandshakeState))
    restoreHState Context
    ctx Saved (Maybe HandshakeState)
    baseHState
            expectFinished ByteString
    _ Handshake13
    hs = String -> Maybe String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected (Handshake13 -> String
    forall a. Show a => a -> String
    show Handshake13
    hs) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "finished 13")

        -- Note: here the server could send updated NST too, however the library
        -- currently has no API to handle resumption and client authentication
        -- together, see discussion in #133
        if CertificateChain -> Bool
    isNullCertificateChain CertificateChain
    certs
            then Context -> [PendingAction] -> IO ()
    setPendingActions Context
    ctx [ Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
    PendingActionHash Bool
    False ByteString -> Handshake13 -> IO ()
    expectFinished ]
            else Context -> [PendingAction] -> IO ()
    setPendingActions Context
    ctx [ Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
    PendingActionHash Bool
    False (ServerParams -> Context -> ByteString -> Handshake13 -> IO ()
    forall (m :: * -> *).
    MonadIO m =>
    ServerParams -> Context -> ByteString -> Handshake13 -> m ()
    expectCertVerify ServerParams
    sparams Context
    ctx)
                                       , Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
    PendingActionHash Bool
    False ByteString -> Handshake13 -> IO ()
    expectFinished
                                       ]

    postHandshakeAuthServerWith ServerParams
    _ Context
    _ Handshake13
    _ =
        TLSError -> IO ()
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO ()) -> TLSError -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (String, Bool, AlertDescription) -> TLSError
    Error_Protocol (String
    "unexpected handshake message received in postHandshakeAuthServerWith", Bool
    True, AlertDescription
    UnexpectedMessage)

    contextSync :: Context -> ServerState -> IO ()
    contextSync :: Context -> ServerState -> IO ()
    contextSync Context
    ctx ServerState
    ctl = case Context -> HandshakeSync
    ctxHandshakeSync Context
    ctx of
        HandshakeSync Context -> ClientState -> IO ()
    _ Context -> ServerState -> IO ()
    sync -> Context -> ServerState -> IO ()
    sync Context
    ctx ServerState
    ctl