{-# 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 (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 [CipherID]
ciphers [CompressionID]
compressions [ExtensionRaw]
exts Maybe DeprecatedRecord
_) = 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
    -- when (legacyVersion == SSL3) $ throwCore $ Error_Protocol ("SSL 3.0 is not supported", True, 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
&&
          (CipherID
0x5600 CipherID -> [CipherID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CipherID]
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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_SupportedVersions [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe SupportedVersions)
-> Maybe SupportedVersions
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe SupportedVersions
forall a. Extension a => MessageType -> DeprecatedRecord -> Maybe a
extensionDecode MessageType
MsgTClientHello of
            Just (SupportedVersionsClientHello [Version]
vers) -> [Version]
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 (m :: * -> *) a. Monad m => a -> m a
return Version
cver
      Maybe Version
Nothing   ->
        if (Version
TLS13 Version -> [Version] -> 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Version
v

    -- SNI (Server Name Indication)
    let serverName :: Maybe String
serverName = case CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_ServerName [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe ServerName) -> Maybe ServerName
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe ServerName
forall a. Extension a => MessageType -> DeprecatedRecord -> 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, DeprecatedRecord)
_)           = 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 (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]
-> [CipherID]
-> Maybe String
-> Version
-> [CompressionID]
-> Session
-> IO ()
handshakeServerWithTLS12 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [CipherID]
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]
-> [CipherID]
-> Maybe String
-> Session
-> IO ()
handshakeServerWithTLS13 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [CipherID]
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]
-> [CipherID]
-> Maybe String
-> Version
-> [CompressionID]
-> Session
-> IO ()
handshakeServerWithTLS12 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [CipherID]
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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleECGroups)
        hasCommonGroupForFFDHE :: Bool
hasCommonGroupForFFDHE = Bool -> Bool
not ([Group] -> 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 (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 (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 (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 (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 (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 (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 (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 DeprecatedRecord
clientSessionId)) -> do
                let resume :: IO (Maybe SessionData)
resume = IO (Maybe SessionData) -> IO (Maybe SessionData)
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 -> DeprecatedRecord -> IO (Maybe SessionData)
sessionResume (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) DeprecatedRecord
clientSessionId
                IO (Maybe SessionData)
resume IO (Maybe SessionData)
-> (Maybe SessionData -> IO (Maybe SessionData))
-> IO (Maybe SessionData)
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 DeprecatedRecord
Nothing)                -> Maybe SessionData -> IO (Maybe SessionData)
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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_EcPointFormats [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe EcPointFormatsSupported)
-> Maybe EcPointFormatsSupported
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe EcPointFormatsSupported
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 (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 ((CipherID -> [CipherID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CipherID]
ciphers) (CipherID -> Bool) -> (Cipher -> CipherID) -> Cipher -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> CipherID
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. [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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
            | SessionData -> CipherID
sessionCipher SessionData
sd CipherID -> [CipherID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CipherID]
ciphers            = Maybe SessionData -> m (Maybe SessionData)
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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
m
          where emsSession :: Bool
emsSession = SessionFlag
SessionEMS SessionFlag -> [SessionFlag] -> 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 (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 :: DeprecatedRecord
masterSecret = SessionData -> DeprecatedRecord
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 -> DeprecatedRecord -> HandshakeM ()
setMasterSecret Version
chosenVersion Role
ServerRole DeprecatedRecord
masterSecret
            Context -> MasterSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (DeprecatedRecord -> MasterSecret
MasterSecret DeprecatedRecord
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 (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
                            DeprecatedRecord
vf <- Context -> TLSSt DeprecatedRecord -> IO DeprecatedRecord
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt DeprecatedRecord -> IO DeprecatedRecord)
-> TLSSt DeprecatedRecord -> IO DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ do
                                    DeprecatedRecord
cvf <- Role -> TLSSt DeprecatedRecord
getVerifiedData Role
ClientRole
                                    DeprecatedRecord
svf <- Role -> TLSSt DeprecatedRecord
getVerifiedData Role
ServerRole
                                    DeprecatedRecord -> TLSSt DeprecatedRecord
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord -> TLSSt DeprecatedRecord)
-> DeprecatedRecord -> TLSSt DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ SecureRenegotiation -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (DeprecatedRecord -> Maybe DeprecatedRecord -> SecureRenegotiation
SecureRenegotiation DeprecatedRecord
cvf (Maybe DeprecatedRecord -> SecureRenegotiation)
-> Maybe DeprecatedRecord -> SecureRenegotiation
forall a b. (a -> b) -> a -> b
$ DeprecatedRecord -> Maybe DeprecatedRecord
forall a. a -> Maybe a
Just DeprecatedRecord
svf)
                            [ExtensionRaw] -> IO [ExtensionRaw]
forall (m :: * -> *) a. Monad m => a -> m a
return [ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_SecureRenegotiation DeprecatedRecord
vf ]
                    else [ExtensionRaw] -> IO [ExtensionRaw]
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 :: DeprecatedRecord
raw = ExtendedMasterSecret -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode ExtendedMasterSecret
ExtendedMasterSecret
                                in [ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_ExtendedMasterSecret DeprecatedRecord
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 (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 (m :: * -> *) a. Monad m => a -> m a
return [ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_ServerName DeprecatedRecord
""]
                      Maybe String
Nothing -> [ExtensionRaw] -> IO [ExtensionRaw]
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 (m :: * -> *) a. Monad m => a -> m a
return (Handshake -> IO Handshake) -> Handshake -> IO Handshake
forall a b. (a -> b) -> a -> b
$ Version
-> ServerRandom
-> Session
-> CipherID
-> CompressionID
-> [ExtensionRaw]
-> Handshake
ServerHello Version
chosenVersion ServerRandom
srand Session
session (Cipher -> CipherID
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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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 (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.
            DeprecatedRecord
msgs  <- Context -> HandshakeM DeprecatedRecord -> IO DeprecatedRecord
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM DeprecatedRecord -> IO DeprecatedRecord)
-> HandshakeM DeprecatedRecord -> IO DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ [DeprecatedRecord] -> DeprecatedRecord
B.concat ([DeprecatedRecord] -> DeprecatedRecord)
-> HandshakeM [DeprecatedRecord] -> HandshakeM DeprecatedRecord
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeM [DeprecatedRecord]
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
-> DeprecatedRecord
-> DigitallySigned
-> IO Bool
checkCertificateVerify Context
ctx Version
usedVersion PubKey
pubKey DeprecatedRecord
msgs DigitallySigned
dsig
            ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
            RecvState m -> IO (RecvState m)
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 (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 (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 (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 DeprecatedRecord
_) = RecvState m -> m (RecvState m)
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 :: 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 (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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_SignatureAlgorithms [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe SignatureAlgorithms)
-> Maybe SignatureAlgorithms
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe SignatureAlgorithms
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_NegotiatedGroups [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe NegotiatedGroups)
-> Maybe NegotiatedGroups
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe NegotiatedGroups
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 :: (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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_NegotiatedGroups [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe NegotiatedGroups)
-> Maybe NegotiatedGroups
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe NegotiatedGroups
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 (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 CipherID -> Maybe SignatureAlgorithmsCert
forall b. Extension b => CipherID -> Maybe b
withExt CipherID
extensionID_SignatureAlgorithmsCert of
        Just (SignatureAlgorithmsCert [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas
        Maybe SignatureAlgorithmsCert
Nothing ->
            case CipherID -> Maybe SignatureAlgorithms
forall b. Extension b => CipherID -> Maybe b
withExt CipherID
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 :: CipherID -> Maybe b
withExt CipherID
extId = CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extId [ExtensionRaw]
exts Maybe DeprecatedRecord -> (DeprecatedRecord -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe b
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 :: 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]
-> [CipherID]
-> Maybe String
-> Session
-> IO ()
handshakeServerWithTLS13 ServerParams
sparams Context
ctx Version
chosenVersion [ExtensionRaw]
exts [CipherID]
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 CipherID
eid DeprecatedRecord
_) -> CipherID
eid CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== CipherID
extensionID_PreSharedKey) ([ExtensionRaw] -> Bool) -> [ExtensionRaw] -> Bool
forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> [ExtensionRaw]
forall a. [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 (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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_EarlyData [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe EarlyDataIndication)
-> Maybe EarlyDataIndication
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe EarlyDataIndication
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_KeyShare [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe KeyShare) -> Maybe KeyShare
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe KeyShare
forall a. Extension a => MessageType -> DeprecatedRecord -> Maybe a
extensionDecode MessageType
MsgTClientHello of
          Just (KeyShareClientHello [KeyShareEntry]
kses) -> [KeyShareEntry] -> IO [KeyShareEntry]
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
"key exchange not implemented, expected key_share extension", Bool
True, AlertDescription
HandshakeFailure)
    case [KeyShareEntry] -> [Group] -> Maybe KeyShareEntry
forall (t :: * -> *).
Foldable t =>
t KeyShareEntry -> [Group] -> Maybe KeyShareEntry
findKeyShare [KeyShareEntry]
keyShares [Group]
serverGroups 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 ((CipherID -> [CipherID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CipherID]
clientCiphers) (CipherID -> Bool) -> (Cipher -> CipherID) -> Cipher -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> CipherID
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 :: t KeyShareEntry -> [Group] -> Maybe KeyShareEntry
findKeyShare t KeyShareEntry
_      [] = Maybe KeyShareEntry
forall a. Maybe a
Nothing
    findKeyShare t KeyShareEntry
ks (Group
g:[Group]
gs) = case (KeyShareEntry -> Bool) -> t KeyShareEntry -> Maybe KeyShareEntry
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\KeyShareEntry
ent -> KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
ent Group -> Group -> Bool
forall a. Eq a => a -> a -> Bool
== Group
g) t KeyShareEntry
ks of
      Just KeyShareEntry
k  -> KeyShareEntry -> Maybe KeyShareEntry
forall a. a -> Maybe a
Just KeyShareEntry
k
      Maybe KeyShareEntry
Nothing -> t KeyShareEntry -> [Group] -> Maybe KeyShareEntry
findKeyShare t KeyShareEntry
ks [Group]
gs

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 (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
    (DeprecatedRecord
psk, Maybe (DeprecatedRecord, Int, Int)
binderInfo, Bool
is0RTTvalid) <- IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
choosePSK
    SecretPair EarlySecret
earlyKey <- Context
-> CipherChoice
-> Either DeprecatedRecord (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (DeprecatedRecord
-> Either DeprecatedRecord (BaseSecret EarlySecret)
forall a b. a -> Either a b
Left DeprecatedRecord
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 (DeprecatedRecord, Int, Int) -> IO [ExtensionRaw]
forall b.
Integral b =>
BaseSecret EarlySecret
-> Maybe (DeprecatedRecord, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
earlySecret Maybe (DeprecatedRecord, 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 (DeprecatedRecord, Int, Int) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (DeprecatedRecord, 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe (Credential, HashAndSignatureAlgorithm)
mCredInfo <- if Bool
authenticated then Maybe (Credential, HashAndSignatureAlgorithm)
-> IO (Maybe (Credential, HashAndSignatureAlgorithm))
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
    (DeprecatedRecord
ecdhe,KeyShareEntry
keyShare) <- Context -> KeyShareEntry -> IO (DeprecatedRecord, 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 (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
-> DeprecatedRecord
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret Context
ctx CipherChoice
choice BaseSecret EarlySecret
earlySecret DeprecatedRecord
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 (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 (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 DeprecatedRecord
shs = ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        Handshake13
rawFinished <- Context -> Hash -> DeprecatedRecord -> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> DeprecatedRecord -> m Handshake13
makeFinished Context
ctx Hash
usedHash DeprecatedRecord
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 (m :: * -> *) a. Monad m => a -> m a
return (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, BaseSecret HandshakeSecret
handSecret)
    Millisecond
sfSentTime <- IO Millisecond
getCurrentTimeFromBase
    ----------------------------------------------------------------
    DeprecatedRecord
hChSf <- Context -> IO DeprecatedRecord
forall (m :: * -> *). MonadIO m => Context -> m DeprecatedRecord
transcriptHash Context
ctx
    SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> DeprecatedRecord
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handSecret DeprecatedRecord
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 :: DeprecatedRecord -> Handshake13 -> m ()
expectFinished DeprecatedRecord
hChBeforeCf (Finished13 DeprecatedRecord
verifyData) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            let ClientTrafficSecret DeprecatedRecord
chs = ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
            Hash
-> DeprecatedRecord
-> DeprecatedRecord
-> DeprecatedRecord
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Hash
-> DeprecatedRecord -> DeprecatedRecord -> DeprecatedRecord -> m ()
checkFinished Hash
usedHash DeprecatedRecord
chs DeprecatedRecord
hChBeforeCf DeprecatedRecord
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 DeprecatedRecord
_ 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
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx (ServerParams
-> Context
-> DeprecatedRecord
-> Handshake13
-> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> DeprecatedRecord -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
          Context
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx DeprecatedRecord -> Handshake13 -> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
DeprecatedRecord -> 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 -> (DeprecatedRecord -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
True DeprecatedRecord -> Handshake13 -> IO ()
forall (m :: * -> *).
MonadIO m =>
DeprecatedRecord -> 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
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (DeprecatedRecord -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx DeprecatedRecord -> Handshake13 -> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
DeprecatedRecord -> 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 (m :: * -> *) a. Monad m => a -> m a
return ServerRandom
srand

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

    choosePSK :: IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
choosePSK = case CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_PreSharedKey [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe PreSharedKey) -> Maybe PreSharedKey
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe PreSharedKey
forall a. Extension a => MessageType -> DeprecatedRecord -> Maybe a
extensionDecode MessageType
MsgTClientHello of
      Just (PreSharedKeyClientHello (PskIdentity DeprecatedRecord
sessionId Word32
obfAge:[PskIdentity]
_) bnds :: [DeprecatedRecord]
bnds@(DeprecatedRecord
bnd:[DeprecatedRecord]
_)) -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PskKexMode] -> 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes then do
              let len :: Int
len = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((DeprecatedRecord -> Int) -> [DeprecatedRecord] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\DeprecatedRecord
x -> DeprecatedRecord -> Int
B.length DeprecatedRecord
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [DeprecatedRecord]
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 -> DeprecatedRecord -> IO (Maybe SessionData)
sessionResumeOnlyOnce SessionManager
mgr DeprecatedRecord
sessionId
                                else SessionManager -> DeprecatedRecord -> IO (Maybe SessionData)
sessionResume SessionManager
mgr DeprecatedRecord
sessionId
              case Maybe SessionData
msdata of
                Just SessionData
sdata -> do
                    let Just TLS13TicketInfo
tinfo = SessionData -> Maybe TLS13TicketInfo
sessionTicketInfo SessionData
sdata
                        psk :: DeprecatedRecord
psk = SessionData -> DeprecatedRecord
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
                        (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
-> IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
psk, (DeprecatedRecord, Int, Int) -> Maybe (DeprecatedRecord, Int, Int)
forall a. a -> Maybe a
Just (DeprecatedRecord
bnd,Int
0::Int,Int
len),Bool
is0RTTvalid)
                      else
                        -- fall back to full handshake
                        (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
-> IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
zero, Maybe (DeprecatedRecord, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
                Maybe SessionData
_      -> (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
-> IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
zero, Maybe (DeprecatedRecord, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
              else (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
-> IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
zero, Maybe (DeprecatedRecord, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
      Maybe PreSharedKey
_ -> (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
-> IO (DeprecatedRecord, Maybe (DeprecatedRecord, Int, Int), Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
zero, Maybe (DeprecatedRecord, 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 DeprecatedRecord
malpn <- Context
-> TLSSt (Maybe DeprecatedRecord) -> IO (Maybe DeprecatedRecord)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe DeprecatedRecord)
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 -> CipherID
sessionCipher SessionData
sdata CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== Cipher -> CipherID
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 -> CipherID
cipherID Cipher
c CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== SessionData -> CipherID
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 DeprecatedRecord
sessionALPN SessionData
sdata Maybe DeprecatedRecord -> Maybe DeprecatedRecord -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe DeprecatedRecord
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 (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 (DeprecatedRecord, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
_ Maybe (DeprecatedRecord, b, Int)
Nothing = [ExtensionRaw] -> IO [ExtensionRaw]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    checkBinder BaseSecret EarlySecret
earlySecret (Just (DeprecatedRecord
binder,b
n,Int
tlen)) = do
        DeprecatedRecord
binder' <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe DeprecatedRecord
-> IO DeprecatedRecord
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
usedHash Int
tlen Maybe DeprecatedRecord
forall a. Maybe a
Nothing
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DeprecatedRecord
binder DeprecatedRecord -> DeprecatedRecord -> Bool
`bytesEq` DeprecatedRecord
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 :: DeprecatedRecord
selectedIdentity = PreSharedKey -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (PreSharedKey -> DeprecatedRecord)
-> PreSharedKey -> DeprecatedRecord
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 (m :: * -> *) a. Monad m => a -> m a
return [CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_PreSharedKey DeprecatedRecord
selectedIdentity]

    decideCredentialInfo :: Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds = do
        [HashAndSignatureAlgorithm]
cHashSigs <- case CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_SignatureAlgorithms [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe SignatureAlgorithms)
-> Maybe SignatureAlgorithms
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe SignatureAlgorithms
forall a. Extension a => MessageType -> DeprecatedRecord -> Maybe a
extensionDecode MessageType
MsgTClientHello 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
"no signature_algorithms extension", Bool
True, AlertDescription
MissingExtension)
            Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> m [HashAndSignatureAlgorithm]
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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
            Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
-> m (Maybe (Credential, HashAndSignatureAlgorithm))
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 :: DeprecatedRecord
serverKeyShare = KeyShare -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (KeyShare -> DeprecatedRecord) -> KeyShare -> DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> KeyShare
KeyShareServerHello KeyShareEntry
keyShare
            selectedVersion :: DeprecatedRecord
selectedVersion = SupportedVersions -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (SupportedVersions -> DeprecatedRecord)
-> SupportedVersions -> DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
            extensions' :: [ExtensionRaw]
extensions' = CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_KeyShare DeprecatedRecord
serverKeyShare
                        ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_SupportedVersions DeprecatedRecord
selectedVersion
                        ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
extensions
            helo :: Handshake13
helo = ServerRandom
-> Session -> CipherID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
srand Session
clientSession (Cipher -> CipherID
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 :: DeprecatedRecord
certReqCtx = DeprecatedRecord
"" -- this must be zero length here.
                certReq :: Handshake13
certReq = ServerParams -> Context -> DeprecatedRecord -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx DeprecatedRecord
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 (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 [DeprecatedRecord
-> CertificateChain -> [[ExtensionRaw]] -> Handshake13
Certificate13 DeprecatedRecord
"" CertificateChain
certChain [[ExtensionRaw]]
forall a. [[a]]
ess]
        DeprecatedRecord
hChSc <- Context -> PacketFlightM b DeprecatedRecord
forall (m :: * -> *). MonadIO m => Context -> m DeprecatedRecord
transcriptHash Context
ctx
        PubKey
pubkey <- Context -> PacketFlightM b PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        Handshake13
vrfy <- Context
-> PubKey
-> HashAndSignatureAlgorithm
-> DeprecatedRecord
-> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> DeprecatedRecord
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
hashSig DeprecatedRecord
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 (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
$ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_ServerName DeprecatedRecord
""
              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 (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. [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
$ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_NegotiatedGroups (DeprecatedRecord -> ExtensionRaw)
-> DeprecatedRecord -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ NegotiatedGroups -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
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
$ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_EarlyData (DeprecatedRecord -> ExtensionRaw)
-> DeprecatedRecord -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ EarlyDataIndication -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
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
        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
        DeprecatedRecord
nonce <- Context -> Int -> IO DeprecatedRecord
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 p. (Num p, Integral a) => a -> p
toSeconds (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
            psk :: DeprecatedRecord
psk = CipherChoice
-> BaseSecret ResumptionSecret
-> DeprecatedRecord
-> DeprecatedRecord
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionMasterSecret DeprecatedRecord
nonce
        (DeprecatedRecord
label, Word32
add) <- Word32
-> DeprecatedRecord
-> Int
-> Millisecond
-> IO (DeprecatedRecord, Word32)
generateSession Word32
life DeprecatedRecord
psk Int
rtt0max Millisecond
rtt
        let nst :: Handshake13
nst = Word32
-> Word32
-> DeprecatedRecord
-> DeprecatedRecord
-> Int
-> Handshake13
forall a.
Integral a =>
Word32
-> Word32
-> DeprecatedRecord
-> DeprecatedRecord
-> a
-> Handshake13
createNewSessionTicket Word32
life Word32
add DeprecatedRecord
nonce DeprecatedRecord
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes
        generateSession :: Word32
-> DeprecatedRecord
-> Int
-> Millisecond
-> IO (DeprecatedRecord, Word32)
generateSession Word32
life DeprecatedRecord
psk Int
maxSize Millisecond
rtt = do
            Session (Just DeprecatedRecord
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
-> DeprecatedRecord
-> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize DeprecatedRecord
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 -> DeprecatedRecord -> SessionData -> IO ()
sessionEstablish SessionManager
mgr DeprecatedRecord
sessionId SessionData
sdata
            (DeprecatedRecord, Word32) -> IO (DeprecatedRecord, Word32)
forall (m :: * -> *) a. Monad m => a -> m a
return (DeprecatedRecord
sessionId, TLS13TicketInfo -> Word32
ageAdd TLS13TicketInfo
tinfo)
        createNewSessionTicket :: Word32
-> Word32
-> DeprecatedRecord
-> DeprecatedRecord
-> a
-> Handshake13
createNewSessionTicket Word32
life Word32
add DeprecatedRecord
nonce DeprecatedRecord
label a
maxSize =
            Word32
-> Word32
-> DeprecatedRecord
-> DeprecatedRecord
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Word32
life Word32
add DeprecatedRecord
nonce DeprecatedRecord
label [ExtensionRaw]
extensions
          where
            tedi :: DeprecatedRecord
tedi = EarlyDataIndication -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (EarlyDataIndication -> DeprecatedRecord)
-> EarlyDataIndication -> DeprecatedRecord
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
$ a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
maxSize
            extensions :: [ExtensionRaw]
extensions = [CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_EarlyData DeprecatedRecord
tedi]
        toSeconds :: a -> p
toSeconds a
i | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0      = p
0
                    | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
604800 = p
604800
                    | Bool
otherwise  = a -> p
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i

    dhModes :: [PskKexMode]
dhModes = case CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_PskKeyExchangeModes [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe PskKeyExchangeModes)
-> Maybe PskKeyExchangeModes
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe PskKeyExchangeModes
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 DeprecatedRecord
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = IO Bool -> RecvHandshake13M IO Bool
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 (DeprecatedRecord
certCtx DeprecatedRecord -> DeprecatedRecord -> Bool
forall a. Eq a => a -> a -> Bool
/= DeprecatedRecord
"") (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 (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 :: DeprecatedRecord
zero = Int -> CompressionID -> DeprecatedRecord
B.replicate Int
hashSize CompressionID
0

expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify :: ServerParams -> Context -> DeprecatedRecord -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx DeprecatedRecord
hChCc (CertVerify13 HashAndSignatureAlgorithm
sigAlg DeprecatedRecord
sig) = IO () -> m ()
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 (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
-> DeprecatedRecord
-> DeprecatedRecord
-> IO Bool
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> DeprecatedRecord
-> DeprecatedRecord
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg DeprecatedRecord
sig DeprecatedRecord
hChCc
    ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
expectCertVerify ServerParams
_ Context
_ DeprecatedRecord
_ 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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_NegotiatedGroups [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe NegotiatedGroups)
-> Maybe NegotiatedGroups
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> DeprecatedRecord -> Maybe NegotiatedGroups
forall a. Extension a => MessageType -> DeprecatedRecord -> 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 :: DeprecatedRecord
serverKeyShare = KeyShare -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (KeyShare -> DeprecatedRecord) -> KeyShare -> DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ Group -> KeyShare
KeyShareHRR Group
g
              selectedVersion :: DeprecatedRecord
selectedVersion = SupportedVersions -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (SupportedVersions -> DeprecatedRecord)
-> SupportedVersions -> DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
              extensions :: [ExtensionRaw]
extensions = [CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_KeyShare DeprecatedRecord
serverKeyShare
                           ,CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_SupportedVersions DeprecatedRecord
selectedVersion]
              hrr :: Handshake13
hrr = ServerRandom
-> Session -> CipherID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
hrrRandom Session
clientSession (Cipher -> CipherID
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
            canSignRSA :: Bool
canSignRSA    = KeyExchangeSignatureAlg
KX_RSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> 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 (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]
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 CipherID -> [ExtensionRaw] -> Maybe DeprecatedRecord
extensionLookup CipherID
extensionID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
exts Maybe DeprecatedRecord
-> (DeprecatedRecord -> Maybe ApplicationLayerProtocolNegotiation)
-> Maybe ApplicationLayerProtocolNegotiation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType
-> DeprecatedRecord -> Maybe ApplicationLayerProtocolNegotiation
forall a. Extension a => MessageType -> DeprecatedRecord -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Maybe ApplicationLayerProtocolNegotiation
Nothing -> [ExtensionRaw] -> IO [ExtensionRaw]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just (ApplicationLayerProtocolNegotiation [DeprecatedRecord]
protos) -> do
            case ServerHooks -> Maybe ([DeprecatedRecord] -> IO DeprecatedRecord)
onALPNClientSuggest (ServerHooks -> Maybe ([DeprecatedRecord] -> IO DeprecatedRecord))
-> ServerHooks -> Maybe ([DeprecatedRecord] -> IO DeprecatedRecord)
forall a b. (a -> b) -> a -> b
$ ServerParams -> ServerHooks
serverHooks ServerParams
sparams of
                Just [DeprecatedRecord] -> IO DeprecatedRecord
io -> do
                    DeprecatedRecord
proto <- [DeprecatedRecord] -> IO DeprecatedRecord
io [DeprecatedRecord]
protos
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DeprecatedRecord
proto DeprecatedRecord -> DeprecatedRecord -> Bool
forall a. Eq a => a -> a -> Bool
== DeprecatedRecord
"") (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
                        DeprecatedRecord -> TLSSt ()
setNegotiatedProtocol DeprecatedRecord
proto
                    [ExtensionRaw] -> IO [ExtensionRaw]
forall (m :: * -> *) a. Monad m => a -> m a
return [ CipherID -> DeprecatedRecord -> ExtensionRaw
ExtensionRaw CipherID
extensionID_ApplicationLayerProtocolNegotiation
                                            (ApplicationLayerProtocolNegotiation -> DeprecatedRecord
forall a. Extension a => a -> DeprecatedRecord
extensionEncode (ApplicationLayerProtocolNegotiation -> DeprecatedRecord)
-> ApplicationLayerProtocolNegotiation -> DeprecatedRecord
forall a b. (a -> b) -> a -> b
$ [DeprecatedRecord] -> ApplicationLayerProtocolNegotiation
ApplicationLayerProtocolNegotiation [DeprecatedRecord
proto]) ]
                Maybe ([DeprecatedRecord] -> IO DeprecatedRecord)
_ -> [ExtensionRaw] -> IO [ExtensionRaw]
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]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hss Credentials
creds
        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 (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 (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 (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 DeprecatedRecord
newCertReqContext Context
ctx = Context -> Int -> IO DeprecatedRecord
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
        DeprecatedRecord
certReqCtx <- Context -> IO DeprecatedRecord
newCertReqContext Context
ctx
        let certReq :: Handshake13
certReq = ServerParams -> Context -> DeprecatedRecord -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx DeprecatedRecord
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 (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 DeprecatedRecord
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = do
    Maybe Handshake13
mCertReq <- Context -> DeprecatedRecord -> IO (Maybe Handshake13)
getCertRequest13 Context
ctx DeprecatedRecord
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, DeprecatedRecord
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, DeprecatedRecord)
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 :: DeprecatedRecord -> Handshake13 -> IO ()
expectFinished DeprecatedRecord
hChBeforeCf (Finished13 DeprecatedRecord
verifyData) = do
            Hash
-> DeprecatedRecord
-> DeprecatedRecord
-> DeprecatedRecord
-> IO ()
forall (m :: * -> *).
MonadIO m =>
Hash
-> DeprecatedRecord -> DeprecatedRecord -> DeprecatedRecord -> m ()
checkFinished Hash
usedHash DeprecatedRecord
applicationSecretN DeprecatedRecord
hChBeforeCf DeprecatedRecord
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 DeprecatedRecord
_ 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 -> (DeprecatedRecord -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False DeprecatedRecord -> Handshake13 -> IO ()
expectFinished ]
        else Context -> [PendingAction] -> IO ()
setPendingActions Context
ctx [ Bool -> (DeprecatedRecord -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False (ServerParams -> Context -> DeprecatedRecord -> Handshake13 -> IO ()
forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> DeprecatedRecord -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
                                   , Bool -> (DeprecatedRecord -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
False DeprecatedRecord -> 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