{-# 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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]
_    -> forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show [Handshake]
hss) (forall a. a -> Maybe a
Just String
"client hello")

-- | Put the server context in handshake mode.
--
-- Expect a client hello message as parameter.
-- This is useful when the client hello has been already poped from the recv layer to inspect the packet.
--
-- When the function returns, a new handshake has been succesfully negociated.
-- On any error, a HandshakeFailed exception is raised.
--
-- handshake protocol (<- receiving, -> sending, [] optional):
--    (no session)           (session resumption)
--      <- client hello       <- client hello
--      -> server hello       -> server hello
--      -> [certificate]
--      -> [server key xchg]
--      -> [cert request]
--      -> hello done
--      <- [certificate]
--      <- client key xchg
--      <- [cert verify]
--      <- change cipher      -> change cipher
--      <- finish             -> finish
--      -> change cipher      <- change cipher
--      -> finish             <- finish
--
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
handshakeServerWith ServerParams
sparams Context
ctx clientHello :: Handshake
clientHello@(ClientHello Version
legacyVersion ClientRandom
_ Session
clientSession [ExtensionID]
ciphers [CompressionID]
compressions [ExtensionRaw]
exts Maybe ByteString
_) = do
    Established
established <- Context -> IO Established
ctxEstablished Context
ctx
    -- renego is not allowed in TLS 1.3
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established forall a. Eq a => a -> a -> Bool
/= Established
NotEstablished) forall a b. (a -> b) -> a -> b
$ do
        Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Version -> TLSSt Version
getVersionWithDefault Version
TLS10)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS13) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
renegotiation Bool -> Bool -> Bool
&& Bool -> Bool
not (Supported -> Bool
supportedClientInitiatedRenegotiation forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 <- forall a. Context -> (Measurement -> IO a) -> IO a
withMeasure Context
ctx (ServerHooks -> Measurement -> IO Bool
onNewHandshake forall a b. (a -> b) -> a -> b
$ ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
handshakeAuthorized (forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
legacyVersion forall a. Eq a => a -> a -> Bool
== Version
SSL2) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
legacyVersion forall a. Eq a => a -> a -> Bool
== Version
SSL3) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"SSL 3.0 is not supported", Bool
True, AlertDescription
ProtocolVersion)

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

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

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

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

    -- If compression is null, commonCompressions should be [0].
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Compression]
commonCompressions) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
        possibleFFGroups :: [Group]
possibleFFGroups = [Group]
possibleGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
        hasCommonGroupForECDHE :: Bool
hasCommonGroupForECDHE = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleECGroups)
        hasCommonGroupForFFDHE :: Bool
hasCommonGroupForFFDHE = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleFFGroups)
        hasCustomGroupForFFDHE :: Bool
hasCustomGroupForFFDHE = 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 = 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 -> forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (PubKey
pub PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
possibleHashSigAlgs
                                       Maybe PubKey
Nothing  -> 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 = forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe Int
signingRank Credentials
cltCreds
                               sigAllCreds :: Credentials
sigAllCreds = 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 (forall a. Maybe a -> Bool
isJust 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.
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cipher]
ciphersFilteredVersion) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe Credential
credentialsFindForDecrypting Credentials
creds
                CipherKeyExchangeType
CipherKeyExchange_DH_Anon   -> forall (m :: * -> *) a. Monad m => a -> m a
return   forall a. Maybe a
Nothing
                CipherKeyExchangeType
CipherKeyExchange_DHE_RSA   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
                CipherKeyExchangeType
CipherKeyExchange_DHE_DSS   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_DSS Credentials
signatureCreds
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_ECDSA Credentials
signatureCreds
                CipherKeyExchangeType
_                           -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 <- forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMasterSec Context
ctx Version
chosenVersion MessageType
MsgTClientHello [ExtensionRaw]
exts
    Maybe SessionData
resumeSessionData <- case Session
clientSession of
            (Session (Just ByteString
clientSessionId)) -> do
                let resume :: IO (Maybe SessionData)
resume = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume (Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
clientSessionId
                IO (Maybe SessionData)
resume forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *}.
MonadIO m =>
Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
validateSession Maybe String
serverName Bool
ems
            (Session Maybe ByteString
Nothing)                -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

    -- Currently, we don't send back EcPointFormats. In this case,
    -- the client chooses EcPointFormat_Uncompressed.
    case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EcPointFormats [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just (EcPointFormatsSupported [EcPointFormat]
fs) -> forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ [EcPointFormat] -> TLSSt ()
setClientEcPointFormatSuggest [EcPointFormat]
fs
        Maybe EcPointFormatsSupported
_ -> 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 = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ExtensionID]
ciphers) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) (ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers ServerParams
sparams Credentials
creds Credentials
sigCreds)
        commonCompressions :: [Compression]
commonCompressions    = [Compression] -> [CompressionID] -> [Compression]
compressionIntersectID (Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) [CompressionID]
compressions
        usedCompression :: Compression
usedCompression       = forall a. [a] -> a
head [Compression]
commonCompressions

        validateSession :: Maybe String -> Bool -> Maybe SessionData -> m (Maybe SessionData)
validateSession Maybe String
_   Bool
_   Maybe SessionData
Nothing                     = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Ord a => a -> a -> Bool
< SessionData -> Version
sessionVersion SessionData
sd             = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | SessionData -> ExtensionID
sessionCipher SessionData
sd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
ciphers            = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | SessionData -> CompressionID
sessionCompression SessionData
sd forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CompressionID]
compressions  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | forall a. Maybe a -> Bool
isJust Maybe String
sni Bool -> Bool -> Bool
&& SessionData -> Maybe String
sessionClientSNI SessionData
sd forall a. Eq a => a -> a -> Bool
/= Maybe String
sni      = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            | Bool
ems Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
emsSession                         = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
err, Bool
True, AlertDescription
HandshakeFailure)
            | Bool
otherwise                                     = forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
m
          where emsSession :: Bool
emsSession = SessionFlag
SessionEMS 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
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
            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 forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [Handshake
serverhello]
            let masterSecret :: ByteString
masterSecret = SessionData -> ByteString
sessionSecret SessionData
sessionData
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> Role -> ByteString -> HandshakeM ()
setMasterSecret Version
chosenVersion Role
ServerRole ByteString
masterSecret
            forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
            Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ServerRole
            Context -> IO ()
recvChangeCipherAndFinish Context
ctx
    Context -> IO ()
handshakeTerminate Context
ctx
  where
        ---
        -- When the client sends a certificate, check whether
        -- it is acceptable for the application.
        --
        ---
        makeServerHello :: Session -> IO Handshake
makeServerHello Session
session = do
            ServerRandom
srand <- Context -> Version -> [Version] -> IO ServerRandom
serverRandom Context
ctx Version
chosenVersion forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
            case Maybe Credential
mcred of
                Just Credential
cred          -> forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
                Maybe Credential
_                  -> 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   <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getSecureRenegotiation
            [ExtensionRaw]
secRengExt <- if Bool
secReneg
                    then do
                            ByteString
vf <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
                                    ByteString
cvf <- Role -> TLSSt ByteString
getVerifiedData Role
ClientRole
                                    ByteString
svf <- Role -> TLSSt ByteString
getVerifiedData Role
ServerRole
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode (ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cvf forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
svf)
                            forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SecureRenegotiation ByteString
vf ]
                    else forall (m :: * -> *) a. Monad m => a -> m a
return []
            Bool
ems <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getExtendedMasterSec
            let emsExt :: [ExtensionRaw]
emsExt | Bool
ems = let raw :: ByteString
raw = forall a. Extension a => a -> ByteString
extensionEncode ExtendedMasterSecret
ExtendedMasterSecret
                                in [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ExtendedMasterSecret ByteString
raw ]
                       | Bool
otherwise = []
            [ExtensionRaw]
protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
exts ServerParams
sparams
            [ExtensionRaw]
sniExt   <- do
                Bool
resuming <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
isSessionResuming
                if Bool
resuming
                  then forall (m :: * -> *) a. Monad m => a -> m a
return []
                  else do
                    Maybe String
msni <- 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
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ServerName ByteString
""]
                      Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
            let extensions :: [ExtensionRaw]
extensions = Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
                          forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
secRengExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
emsExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
sniExt
            forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Version -> TLSSt ()
setVersion Version
chosenVersion)
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> ServerRandom -> Cipher -> Compression -> HandshakeM ()
setServerHelloParameters Version
chosenVersion ServerRandom
srand Cipher
usedCipher Compression
usedCompression
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Version
-> ServerRandom
-> Session
-> ExtensionID
-> CompressionID
-> [ExtensionRaw]
-> Handshake
ServerHello Version
chosenVersion ServerRandom
srand Session
session (Cipher -> ExtensionID
cipherID Cipher
usedCipher)
                                               (Compression -> CompressionID
compressionID Compression
usedCompression) [ExtensionRaw]
extensions

        handshakeSendServerData :: IO ()
handshakeSendServerData = do
            Session
serverSession <- Context -> IO Session
newSession Context
ctx
            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 forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
            Context -> Packet -> IO ()
sendPacket Context
ctx 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 -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon
                        CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_RSA
                        CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_DSS
                        CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_RSA
                        CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_ECDSA
                        CipherKeyExchangeType
_                         -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Context -> Packet -> IO ()
sendPacket Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Handshake] -> Packet
Handshake forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) 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.
            --
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerParams -> Bool
serverWantClientCert ServerParams
sparams) forall a b. (a -> b) -> a -> b
$ do
                Version
usedVersion <- 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 forall a. Ord a => a -> a -> Bool
< Version
TLS12 = ([CertificateType]
defaultCertTypes, forall a. Maybe a
Nothing)
                        | Bool
otherwise =
                            let as :: [HashAndSignatureAlgorithm]
as = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                             in (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType [HashAndSignatureAlgorithm]
as, forall a. a -> Maybe a
Just [HashAndSignatureAlgorithm]
as)
                    creq :: Handshake
creq = [CertificateType]
-> Maybe [HashAndSignatureAlgorithm]
-> [DistinguishedName]
-> Handshake
CertRequest [CertificateType]
certTypes Maybe [HashAndSignatureAlgorithm]
hashSigs
                               (forall a b. (a -> b) -> [a] -> [b]
map SignedExact Certificate -> DistinguishedName
extractCAname forall a b. (a -> b) -> a -> b
$ ServerParams -> [SignedExact Certificate]
serverCACertificates ServerParams
sparams)
                forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx 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 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
            (DHParams
dhparams, DHPrivate
priv, DHPublic
pub) <-
                    case [Group]
possibleFFGroups of
                        []  ->
                            let dhparams :: DHParams
dhparams = forall a. String -> Maybe a -> a
fromJust String
"server DHE Params" 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
                                        forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx 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
                                        forall (m :: * -> *) a. Monad m => a -> m a
return (DHParams
dhparams, DHPrivate
priv, DHPublic
pub)
                        Group
g:[Group]
_ -> do
                            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx 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

            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
serverParams
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ DHPrivate -> HandshakeM ()
setDHPrivate DHPrivate
priv
            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 <- 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 forall a. (a -> Bool) -> [a] -> [a]
filter (PubKey
pubKey PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
hashSigs of
                      []  -> forall a. HasCallStack => String -> a
error (String
"no hash signature for " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
pubKey)
                      HashAndSignatureAlgorithm
x:[HashAndSignatureAlgorithm]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just HashAndSignatureAlgorithm
x
              Version
_     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        generateSKX_DHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
kxsAlg = do
            ServerDHParams
serverParams  <- IO ServerDHParams
setup_DHE
            PubKey
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_RSA ServerDHParams
serverParams DigitallySigned
signed
                KeyExchangeSignatureAlg
KX_DSS -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_DSS ServerDHParams
serverParams DigitallySigned
signed
                KeyExchangeSignatureAlg
_      -> forall a. HasCallStack => String -> a
error (String
"generate skx_dhe unsupported key exchange signature: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg)

        generateSKX_DH_Anon :: IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon = ServerDHParams -> ServerKeyXchgAlgorithmData
SKX_DH_Anon 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
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx 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
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
serverParams
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ GroupPrivate -> HandshakeM ()
setGroupPrivate GroupPrivate
srvpri
            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 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
            Group
grp <- case [Group]
possibleECGroups of
                     []  -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no common group", Bool
True, AlertDescription
HandshakeFailure)
                     Group
g:[Group]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Group
g
            ServerECDHParams
serverParams <- Group -> IO ServerECDHParams
setup_ECDHE Group
grp
            PubKey
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   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_RSA ServerECDHParams
serverParams DigitallySigned
signed
                KeyExchangeSignatureAlg
KX_ECDSA -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_ECDSA ServerECDHParams
serverParams DigitallySigned
signed
                KeyExchangeSignatureAlg
_        -> forall a. HasCallStack => String -> a
error (String
"generate skx_ecdhe unsupported key exchange signature: " forall a. [a] -> [a] -> [a]
++ 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 (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.

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

        processClientCertificate Handshake
p = 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext forall {m :: * -> *}. MonadIO m => Packet -> IO (RecvState m)
processCertificateVerify
        processClientKeyExchange Handshake
p                 = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake
p) (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 <- forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"change cipher message expected"

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

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

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

        processCertificateVerify Packet
p = do
            Maybe CertificateChain
chain <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        | Bool
otherwise                 -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall {m :: * -> *} {m :: * -> *}.
(MonadIO m, MonadIO m) =>
Packet -> m (RecvState m)
expectChangeCipher Packet
p

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

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

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

checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain
checkValidClientCertChain :: forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
errmsg = do
    Maybe CertificateChain
chain <- 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 -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
throwerror
        Just CertificateChain
cc | CertificateChain -> Bool
isNullCertificateChain CertificateChain
cc -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
throwerror
                | Bool
otherwise                 -> forall (m :: * -> *) a. Monad m => a -> m a
return CertificateChain
cc

hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
exts =
    let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_SignatureAlgorithms [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
            -- See Section 7.4.1.4.1 of RFC 5246.
            Maybe SignatureAlgorithms
Nothing -> [(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureECDSA)
                       ,(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureRSA)
                       ,(HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureDSS)]
            Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm]
sas
        sHashSigs :: [HashAndSignatureAlgorithm]
sHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures 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 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs

negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
    Just (NegotiatedGroups [Group]
clientGroups) ->
        let serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
        in [Group]
serverGroups 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 = forall a. a -> Maybe a
Just PubKey
pubkey
    | Bool
otherwise = 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 (forall a. (a -> Bool) -> [a] -> [a]
filter Credential -> Bool
p [Credential]
l)

filterSortCredentials :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials :: forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe a
rankFun (Credentials [Credential]
creds) =
    let orderedPairs :: [(Maybe a, Credential)]
orderedPairs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn 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 forall a. Ord a => a -> a -> Bool
< Version
TLS13 = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
          Maybe NegotiatedGroups
Nothing                    -> forall a b. a -> b -> a
const Bool
True
          Just (NegotiatedGroups [Group]
sg) -> (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
sg)
      | Bool
otherwise   = 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 forall {b}. Extension b => ExtensionID -> Maybe b
withExt ExtensionID
extensionID_SignatureAlgorithmsCert of
        Just (SignatureAlgorithmsCert [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas
        Maybe SignatureAlgorithmsCert
Nothing ->
            case forall {b}. Extension b => ExtensionID -> Maybe b
withExt ExtensionID
extensionID_SignatureAlgorithms of
                Maybe SignatureAlgorithms
Nothing                        -> forall a. a -> a
id
                Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas
  where
    withExt :: ExtensionID -> Maybe b
withExt ExtensionID
extId = ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extId [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello
    withAlgs :: [HashAndSignatureAlgorithm] -> Credentials -> Credentials
withAlgs [HashAndSignatureAlgorithm]
sas = (Credential -> Bool) -> Credentials -> Credentials
filterCredentials ([HashAndSignatureAlgorithm] -> Credential -> Bool
credentialMatchesHashSignatures [HashAndSignatureAlgorithm]
sas)

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

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

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

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

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

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

    let expectEndOfEarlyData :: Handshake13 -> IO ()
expectEndOfEarlyData Handshake13
EndOfEarlyData13 =
            forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
        expectEndOfEarlyData Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (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
        forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
          Bool
skip <- forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx Handshake13 -> RecvHandshake13M IO Bool
expectCertificate
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
skip forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx (forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx)
          forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished
          forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
      else if Bool
rtt0OK Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx) then
        Context -> [PendingAction] -> IO ()
setPendingActions Context
ctx [Bool -> (Handshake13 -> IO ()) -> PendingAction
PendingAction Bool
True Handshake13 -> IO ()
expectEndOfEarlyData
                              ,Bool -> (ByteString -> Handshake13 -> IO ()) -> PendingAction
PendingActionHash Bool
True forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished]
      else
        forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall {m :: * -> *}.
MonadIO m =>
ByteString -> Handshake13 -> m ()
expectFinished
          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 forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
        forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersion Version
chosenVersion
        forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Cipher -> HandshakeM (Either TLSError ())
setHelloParameters13 Cipher
usedCipher
        forall (m :: * -> *) a. Monad m => a -> m a
return ServerRandom
srand

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

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

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

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

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

    decideCredentialInfo :: Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds = do
        [HashAndSignatureAlgorithm]
cHashSigs <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_SignatureAlgorithms [ExtensionRaw]
exts of
            Maybe ByteString
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no signature_algorithms extension", Bool
True, AlertDescription
MissingExtension)
            Just ByteString
sa -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello ByteString
sa of
              Maybe SignatureAlgorithms
Nothing -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"broken signature_algorithms extension", Bool
True, AlertDescription
DecodeError)
              Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> 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 = forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
            hashSigs :: [HashAndSignatureAlgorithm]
hashSigs = [HashAndSignatureAlgorithm]
sHashSigs 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 -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
            Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs

    sendServerHello :: KeyShareEntry
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare ServerRandom
srand [ExtensionRaw]
extensions = do
        let serverKeyShare :: ByteString
serverKeyShare = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> KeyShare
KeyShareServerHello KeyShareEntry
keyShare
            selectedVersion :: ByteString
selectedVersion = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
            extensions' :: [ExtensionRaw]
extensions' = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_KeyShare ByteString
serverKeyShare
                        forall a. a -> [a] -> [a]
: ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SupportedVersions ByteString
selectedVersion
                        forall a. a -> [a] -> [a]
: [ExtensionRaw]
extensions
            helo :: Handshake13
helo = ServerRandom
-> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
srand Session
clientSession (Cipher -> ExtensionID
cipherID Cipher
usedCipher) [ExtensionRaw]
extensions'
        forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx 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
        forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerParams -> Bool
serverWantClientCert ServerParams
sparams) forall a b. (a -> b) -> a -> b
$ do
            let certReqCtx :: ByteString
certReqCtx = ByteString
"" -- this must be zero length here.
                certReq :: Handshake13
certReq = ServerParams -> Context -> ByteString -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx
            forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq]
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setCertReqSent Bool
True

        let CertificateChain [SignedExact Certificate]
cs = CertificateChain
certChain
            ess :: [[a]]
ess = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
cs) []
        forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [ByteString -> CertificateChain -> [[ExtensionRaw]] -> Handshake13
Certificate13 ByteString
"" CertificateChain
certChain forall {a}. [[a]]
ess]
        ByteString
hChSc <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
        PubKey
pubkey <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        Handshake13
vrfy <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
hashSig ByteString
hChSc
        forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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
_  -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ServerName ByteString
""
              Maybe String
Nothing -> forall a. Maybe a
Nothing
        Maybe Group
mgroup <- 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
              | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
serverGroups = forall a. Maybe a
Nothing
              | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall a. Eq a => a -> a -> Bool
== forall a. [a] -> a
head [Group]
serverGroups) Maybe Group
mgroup = forall a. Maybe a
Nothing
              | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_NegotiatedGroups forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode ([Group] -> NegotiatedGroups
NegotiatedGroups [Group]
serverGroups)
        let earlyDataExtension :: Maybe ExtensionRaw
earlyDataExtension
              | Bool
rtt0OK = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_EarlyData forall a b. (a -> b) -> a -> b
$ forall a. Extension a => a -> ByteString
extensionEncode (Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a. Maybe a
Nothing)
              | Bool
otherwise = forall a. Maybe a
Nothing
        let extensions :: [ExtensionRaw]
extensions = Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
                      forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
catMaybes [Maybe ExtensionRaw
earlyDataExtension
                                   ,Maybe ExtensionRaw
groupExtension
                                   ,Maybe ExtensionRaw
sniExtension
                                   ]
                      forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt
        [ExtensionRaw]
extensions' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
onEncryptedExtensionsCreating (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) [ExtensionRaw]
extensions
        forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx 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 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sendNST forall a b. (a -> b) -> a -> b
$ do
        Millisecond
cfRecvTime <- IO Millisecond
getCurrentTimeFromBase
        let rtt :: Millisecond
rtt = Millisecond
cfRecvTime forall a. Num a => a -> a -> a
- Millisecond
sfSentTime
        ByteString
nonce <- Context -> Int -> IO ByteString
getStateRNG Context
ctx Int
32
        BaseSecret ResumptionSecret
resumptionMasterSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
        let life :: Word32
life = forall {a} {a}. (Num a, Integral a) => a -> a
toSeconds forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverTicketLifetime ServerParams
sparams
            psk :: ByteString
psk = CipherChoice
-> BaseSecret ResumptionSecret -> ByteString -> ByteString
derivePSK CipherChoice
choice BaseSecret ResumptionSecret
resumptionMasterSecret ByteString
nonce
        (ByteString
label, Word32
add) <- Word32
-> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
generateSession Word32
life ByteString
psk Int
rtt0max Millisecond
rtt
        let nst :: Handshake13
nst = forall {p}.
Integral p =>
Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add ByteString
nonce ByteString
label Int
rtt0max
        Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
nst]
      where
        sendNST :: Bool
sendNST = PskKexMode
PSK_DHE_KE forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes
        generateSession :: Word32
-> ByteString -> Int -> Millisecond -> IO (ByteString, Word32)
generateSession Word32
life ByteString
psk Int
maxSize Millisecond
rtt = do
            Session (Just ByteString
sessionId) <- Context -> IO Session
newSession Context
ctx
            TLS13TicketInfo
tinfo <- Word32
-> Either Context Word32 -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo Word32
life (forall a b. a -> Either a b
Left Context
ctx) (forall a. a -> Maybe a
Just Millisecond
rtt)
            SessionData
sdata <- Context
-> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 Context
ctx Cipher
usedCipher TLS13TicketInfo
tinfo Int
maxSize ByteString
psk
            let mgr :: SessionManager
mgr = Shared -> SessionManager
sharedSessionManager forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
            SessionManager -> ByteString -> SessionData -> IO ()
sessionEstablish SessionManager
mgr ByteString
sessionId SessionData
sdata
            forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sessionId, TLS13TicketInfo -> Word32
ageAdd TLS13TicketInfo
tinfo)
        createNewSessionTicket :: Word32 -> Word32 -> ByteString -> ByteString -> p -> Handshake13
createNewSessionTicket Word32
life Word32
add ByteString
nonce ByteString
label p
maxSize =
            Word32
-> Word32
-> ByteString
-> ByteString
-> [ExtensionRaw]
-> Handshake13
NewSessionTicket13 Word32
life Word32
add ByteString
nonce ByteString
label [ExtensionRaw]
extensions
          where
            tedi :: ByteString
tedi = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral p
maxSize
            extensions :: [ExtensionRaw]
extensions = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_EarlyData ByteString
tedi]
        toSeconds :: a -> a
toSeconds a
i | a
i forall a. Ord a => a -> a -> Bool
< a
0      = a
0
                    | a
i forall a. Ord a => a -> a -> Bool
> a
604800 = a
604800
                    | Bool
otherwise  = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i

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

    expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
    expectCertificate :: Handshake13 -> RecvHandshake13M IO Bool
expectCertificate (Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
certCtx forall a. Eq a => a -> a -> Bool
/= ByteString
"") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs
    expectCertificate Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (forall a. a -> Maybe a
Just String
"certificate 13")

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

expectCertVerify :: MonadIO m => ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify :: forall (m :: * -> *).
MonadIO m =>
ServerParams -> Context -> ByteString -> Handshake13 -> m ()
expectCertVerify ServerParams
sparams Context
ctx ByteString
hChCc (CertVerify13 HashAndSignatureAlgorithm
sigAlg ByteString
sig) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    certs :: CertificateChain
certs@(CertificateChain [SignedExact Certificate]
cc) <- forall (m :: * -> *).
MonadIO m =>
Context -> String -> m CertificateChain
checkValidClientCertChain Context
ctx String
"finished 13 message expected"
    PubKey
pubkey <- case [SignedExact Certificate]
cc of
                [] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Certificate -> PubKey
certPubKey forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate SignedExact Certificate
c
    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
ver PubKey
pubkey
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
    Bool
verif <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> ByteString
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg ByteString
sig ByteString
hChCc
    ServerParams -> Context -> CertificateChain -> Bool -> IO ()
clientCertVerify ServerParams
sparams Context
ctx CertificateChain
certs Bool
verif
expectCertVerify ServerParams
_ Context
_ ByteString
_ Handshake13
hs = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
hs) (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 <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
twice forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"Hello retry not allowed again", Bool
True, AlertDescription
HandshakeFailure)
    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> TLSSt ()
setTLS13HRR Bool
True
    forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Cipher -> HandshakeM (Either TLSError ())
setHelloParameters13 Cipher
usedCipher
    let clientGroups :: [Group]
clientGroups = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_NegotiatedGroups [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
          Just (NegotiatedGroups [Group]
gs) -> [Group]
gs
          Maybe NegotiatedGroups
Nothing                    -> []
        possibleGroups :: [Group]
possibleGroups = [Group]
serverGroups forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups
    case [Group]
possibleGroups of
      [] -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no group in common with the client for HRR", Bool
True, AlertDescription
HandshakeFailure)
      Group
g:[Group]
_ -> do
          let serverKeyShare :: ByteString
serverKeyShare = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Group -> KeyShare
KeyShareHRR Group
g
              selectedVersion :: ByteString
selectedVersion = forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
chosenVersion
              extensions :: [ExtensionRaw]
extensions = [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_KeyShare ByteString
serverKeyShare
                           ,ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_SupportedVersions ByteString
selectedVersion]
              hrr :: Handshake13
hrr = ServerRandom
-> Session -> ExtensionID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
hrrRandom Session
clientSession (Cipher -> ExtensionID
cipherID Cipher
usedCipher) [ExtensionRaw]
extensions
          forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
HelloRetryRequest
          forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ do
                forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
hrr]
                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 forall a. (a -> Bool) -> [a] -> [a]
filter (Version
clientVersion forall a. Ord a => a -> a -> Bool
>=) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down [Version]
allowedVersions of
        []  -> forall a. Maybe a
Nothing
        Version
v:[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 = forall a. (a -> Bool) -> [a] -> [a]
filter Cipher -> Bool
authorizedCKE (Supported -> [Cipher]
supportedCiphers 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
            canSignRSA :: Bool
canSignRSA    = KeyExchangeSignatureAlg
KX_RSA forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
            canSignECDSA :: Bool
canSignECDSA  = KeyExchangeSignatureAlg
KX_ECDSA forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
            canEncryptRSA :: Bool
canEncryptRSA = forall a. Maybe a -> Bool
isJust 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 forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Version]
cvs of
        []  -> forall a. Maybe a
Nothing
        Version
v:[Version]
_ -> forall a. a -> Maybe a
Just Version
v
  where
    svs :: [Version]
svs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down [Version]
serverVersions
    cvs :: [Version]
cvs = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a. a -> Down a
Down forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
> Version
SSL3) [Version]
clientVersions

applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol :: Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
exts ServerParams
sparams = do
    -- ALPN (Application Layer Protocol Negotiation)
    case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
exts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Maybe ApplicationLayerProtocolNegotiation
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just (ApplicationLayerProtocolNegotiation [ByteString]
protos) -> do
            case ServerHooks -> Maybe ([ByteString] -> IO ByteString)
onALPNClientSuggest forall a b. (a -> b) -> a -> b
$ ServerParams -> ServerHooks
serverHooks ServerParams
sparams of
                Just [ByteString] -> IO ByteString
io -> do
                    ByteString
proto <- [ByteString] -> IO ByteString
io [ByteString]
protos
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
proto forall a. Eq a => a -> a -> Bool
== ByteString
"") forall a b. (a -> b) -> a -> b
$
                        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"no supported application protocols", Bool
True, AlertDescription
NoApplicationProtocol)
                    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
                        Bool -> TLSSt ()
setExtensionALPN Bool
True
                        ByteString -> TLSSt ()
setNegotiatedProtocol ByteString
proto
                    forall (m :: * -> *) a. Monad m => a -> m a
return [ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
extensionID_ApplicationLayerProtocolNegotiation
                                            (forall a. Extension a => a -> ByteString
extensionEncode forall a b. (a -> b) -> a -> b
$ [ByteString] -> ApplicationLayerProtocolNegotiation
ApplicationLayerProtocolNegotiation [ByteString
proto]) ]
                Maybe ([ByteString] -> IO ByteString)
_ -> 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  []       = forall a. Maybe a
Nothing
    loop  (HashAndSignatureAlgorithm
hs:[HashAndSignatureAlgorithm]
hss) = case HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
credentialsFindForSigning13' HashAndSignatureAlgorithm
hs Credentials
creds of
        Maybe Credential
Nothing   -> [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [HashAndSignatureAlgorithm]
hss
        Just Credential
cred -> 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) = 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
    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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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        -> forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag
KeyUsage_digitalSignature] CertificateChain
certs
        CertificateUsageReject CertificateRejectReason
reason -> forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason

    -- Remember cert chain for later use.
    --
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx 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.
        --
        forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
        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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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.
                forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setClientCertificateChain CertificateChain
certs
                else forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"verification failed"

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

requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer :: ServerParams -> Context -> IO Bool
requestCertificateServer ServerParams
sparams Context
ctx = do
    Bool
tls13 <- forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool
supportsPHA <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getClientSupportsPHA
    let ok :: Bool
ok = Bool
tls13 Bool -> Bool -> Bool
&& Bool
supportsPHA
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$ do
        ByteString
certReqCtx <- Context -> IO ByteString
newCertReqContext Context
ctx
        let certReq :: Handshake13
certReq = ServerParams -> Context -> ByteString -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx
        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) 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 forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq]
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok

postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith :: ServerParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthServerWith ServerParams
sparams Context
ctx h :: Handshake13
h@(Certificate13 ByteString
certCtx CertificateChain
certs [[ExtensionRaw]]
_ext) = do
    Maybe Handshake13
mCertReq <- Context -> ByteString -> IO (Maybe Handshake13)
getCertRequest13 Context
ctx ByteString
certCtx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Handshake13
mCertReq) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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 = forall a. String -> Maybe a -> a
fromJust String
"certReq" Maybe Handshake13
mCertReq

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

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

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

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

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

postHandshakeAuthServerWith ServerParams
_ Context
_ Handshake13
_ =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore 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