{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      : Network.TLS.Handshake.Client
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Network.TLS.Handshake.Client
    ( handshakeClient
    , handshakeClientWith
    , postHandshakeAuthClientWith
    ) where

import Network.TLS.Crypto
import Network.TLS.Context.Internal
import Network.TLS.Parameters
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Credentials
import Network.TLS.Packet hiding (getExtensions)
import Network.TLS.ErrT
import Network.TLS.Extension
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.State
import Network.TLS.Measurement
import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_)
import Network.TLS.Types
import Network.TLS.X509
import qualified Data.ByteString as B
import Data.X509 (ExtKeyUsageFlag(..))

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

import Network.TLS.Handshake.Certificate
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.Wire

handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith ClientParams
cparams Context
ctx Handshake
HelloRequest = ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx
handshakeClientWith ClientParams
_       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 handshakeClientWith", Bool
True, AlertDescription
HandshakeFailure)

-- client part of handshake. send a bunch of handshake of client
-- values intertwined with response from the server.
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx = do
    let groups :: [Group]
groups = case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
              Maybe (ByteString, SessionData)
Nothing         -> [Group]
groupsSupported
              Just (ByteString
_, SessionData
sdata) -> case SessionData -> Maybe Group
sessionGroup SessionData
sdata of
                  Maybe Group
Nothing  -> [] -- TLS 1.2 or earlier
                  Just Group
grp -> Group
grp forall a. a -> [a] -> [a]
: forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Group
grp) [Group]
groupsSupported
        groupsSupported :: [Group]
groupsSupported = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
    ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams Context
ctx [Group]
groups forall a. Maybe a
Nothing

-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says:
-- "The client will also send a
--  ClientHello when the server has responded to its ClientHello with a
--  HelloRetryRequest.  In that case, the client MUST send the same
--  ClientHello without modification, except as follows:"
--
-- So, the ClientRandom in the first client hello is necessary.
handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO ()
handshakeClient' :: ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams Context
ctx [Group]
groups Maybe (ClientRandom, Session, Version)
mparams = do
    Context -> (Measurement -> Measurement) -> IO ()
updateMeasure Context
ctx Measurement -> Measurement
incrementNbHandshakes
    (ClientRandom
crand, Session
clientSession) <- IO (ClientRandom, Session)
generateClientHelloParams
    (Bool
rtt0, [ExtensionID]
sentExtensions) <- Session -> ClientRandom -> IO (Bool, [ExtensionID])
sendClientHello Session
clientSession ClientRandom
crand
    Session -> [ExtensionID] -> IO ()
recvServerHello Session
clientSession [ExtensionID]
sentExtensions
    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(ClientRandom
_, Session
_, Version
v) -> Version
v forall a. Eq a => a -> a -> Bool
== Version
ver) Maybe (ClientRandom, Session, Version)
mparams) 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
"version changed after hello retry", Bool
True, AlertDescription
IllegalParameter)
    -- recvServerHello sets TLS13HRR according to the server random.
    -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise.
    -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR.
    Bool
hrr <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    if Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS13 then
        if Bool
hrr then case forall a. Int -> [a] -> [a]
drop Int
1 [Group]
groups of
            []      -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"group is exhausted in the client side", Bool
True, AlertDescription
IllegalParameter)
            [Group]
groups' -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (ClientRandom, Session, Version)
mparams) 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
"server sent too many hello retries", Bool
True, AlertDescription
UnexpectedMessage)
                Maybe KeyShare
mks <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
                case Maybe KeyShare
mks of
                  Just (KeyShareHRR Group
selectedGroup)
                    | Group
selectedGroup forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups' -> 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
HelloRetryRequest
                          Context -> IO ()
clearTxState Context
ctx
                          let cparams' :: ClientParams
cparams' = ClientParams
cparams { clientEarlyData :: Maybe ByteString
clientEarlyData = forall a. Maybe a
Nothing }
                          forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
                          ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' ClientParams
cparams' Context
ctx [Group
selectedGroup] (forall a. a -> Maybe a
Just (ClientRandom
crand, Session
clientSession, Version
ver))
                    | 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
"server-selected group is not supported", Bool
True, AlertDescription
IllegalParameter)
                  Just KeyShare
_  -> forall a. HasCallStack => String -> a
error String
"handshakeClient': invalid KeyShare value"
                  Maybe KeyShare
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 in HRR, expected key_share extension", Bool
True, AlertDescription
HandshakeFailure)
          else
            ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 ClientParams
cparams Context
ctx Maybe Group
groupToSend
      else do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtt0 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
"server denied TLS 1.3 when connecting with early data", Bool
True, AlertDescription
HandshakeFailure)
        Bool
sessionResuming <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
isSessionResuming
        if Bool
sessionResuming
            then Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ClientRole
            else do ClientParams -> Context -> IO ()
sendClientData ClientParams
cparams Context
ctx
                    Context -> Role -> IO ()
sendChangeCipherAndFinish Context
ctx Role
ClientRole
                    Context -> IO ()
recvChangeCipherAndFinish Context
ctx
        Context -> IO ()
handshakeTerminate Context
ctx
  where ciphers :: [Cipher]
ciphers      = Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        compressions :: [Compression]
compressions = Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        highestVer :: Version
highestVer = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        tls13 :: Bool
tls13 = Version
highestVer forall a. Ord a => a -> a -> Bool
>= Version
TLS13
        ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMasterSec forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        groupToSend :: Maybe Group
groupToSend = forall a. [a] -> Maybe a
listToMaybe [Group]
groups

        -- List of extensions to send in ClientHello, ordered such that we never
        -- terminate with a zero-length extension.  Some buggy implementations
        -- are allergic to an extension with empty data at final position.
        --
        -- Without TLS 1.3, the list ends with extension "signature_algorithms"
        -- with length >= 2 bytes.  When TLS 1.3 is enabled, extensions
        -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key"
        -- (not always present) have length > 0.
        getExtensions :: Maybe (ByteString, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (ByteString, b, CipherChoice, Word32)
pskInfo Bool
rtt0 = forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
            [ IO (Maybe ExtensionRaw)
sniExtension
            , IO (Maybe ExtensionRaw)
secureReneg
            , IO (Maybe ExtensionRaw)
alpnExtension
            , IO (Maybe ExtensionRaw)
emsExtension
            , IO (Maybe ExtensionRaw)
groupExtension
            , IO (Maybe ExtensionRaw)
ecPointExtension
            --, sessionTicketExtension
            , IO (Maybe ExtensionRaw)
signatureAlgExtension
            --, heartbeatExtension
            , IO (Maybe ExtensionRaw)
versionExtension
            , forall {m :: * -> *}. Monad m => Bool -> m (Maybe ExtensionRaw)
earlyDataExtension Bool
rtt0
            , IO (Maybe ExtensionRaw)
keyshareExtension
            , IO (Maybe ExtensionRaw)
cookieExtension
            , IO (Maybe ExtensionRaw)
postHandshakeAuthExtension
            , IO (Maybe ExtensionRaw)
pskExchangeModeExtension
            , forall {m :: * -> *} {b}.
Monad m =>
Maybe (ByteString, b, CipherChoice, Word32)
-> m (Maybe ExtensionRaw)
preSharedKeyExtension Maybe (ByteString, b, CipherChoice, Word32)
pskInfo -- MUST be last (RFC 8446)
            ]

        toExtensionRaw :: Extension e => e -> ExtensionRaw
        toExtensionRaw :: forall e. Extension e => e -> ExtensionRaw
toExtensionRaw e
ext = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw (forall a. Extension a => a -> ExtensionID
extensionID e
ext) (forall a. Extension a => a -> ByteString
extensionEncode e
ext)

        secureReneg :: IO (Maybe ExtensionRaw)
secureReneg  =
                if Supported -> Bool
supportedSecureRenegotiation forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                then forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (Role -> TLSSt ByteString
getVerifiedData Role
ClientRole) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
vd -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
vd forall a. Maybe a
Nothing
                else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        alpnExtension :: IO (Maybe ExtensionRaw)
alpnExtension = do
            Maybe [ByteString]
mprotos <- ClientHooks -> IO (Maybe [ByteString])
onSuggestALPN forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
            case Maybe [ByteString]
mprotos of
                Maybe [ByteString]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just [ByteString]
protos -> do
                    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ [ByteString] -> TLSSt ()
setClientALPNSuggest [ByteString]
protos
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [ByteString] -> ApplicationLayerProtocolNegotiation
ApplicationLayerProtocolNegotiation [ByteString]
protos
        emsExtension :: IO (Maybe ExtensionRaw)
emsExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
            if EMSMode
ems forall a. Eq a => a -> a -> Bool
== EMSMode
NoEMS Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
>= Version
TLS13) (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
                then forall a. Maybe a
Nothing
                else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw ExtendedMasterSecret
ExtendedMasterSecret
        sniExtension :: IO (Maybe ExtensionRaw)
sniExtension = if ClientParams -> Bool
clientUseServerNameIndication ClientParams
cparams
                         then do let sni :: String
sni = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ ClientParams -> (String, ByteString)
clientServerIdentification ClientParams
cparams
                                 forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ String -> TLSSt ()
setClientSNI String
sni
                                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [ServerNameType] -> ServerName
ServerName [String -> ServerNameType
ServerNameHostName String
sni]
                         else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        groupExtension :: IO (Maybe ExtensionRaw)
groupExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [Group] -> NegotiatedGroups
NegotiatedGroups (Supported -> [Group]
supportedGroups forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
        ecPointExtension :: IO (Maybe ExtensionRaw)
ecPointExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [EcPointFormat] -> EcPointFormatsSupported
EcPointFormatsSupported [EcPointFormat
EcPointFormat_Uncompressed]
                                --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2]
        --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend
        --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket

        signatureAlgExtension :: IO (Maybe ExtensionRaw)
signatureAlgExtension = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [HashAndSignatureAlgorithm] -> SignatureAlgorithms
SignatureAlgorithms forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams

        versionExtension :: IO (Maybe ExtensionRaw)
versionExtension
          | Bool
tls13 = do
                let vers :: [Version]
vers = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
>= Version
TLS10) forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [Version] -> SupportedVersions
SupportedVersionsClientHello [Version]
vers
          | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        -- FIXME
        keyshareExtension :: IO (Maybe ExtensionRaw)
keyshareExtension
          | Bool
tls13 = case Maybe Group
groupToSend of
                  Maybe Group
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  Just Group
grp -> do
                      (GroupPrivate
cpri, KeyShareEntry
ent) <- Context -> Group -> IO (GroupPrivate, KeyShareEntry)
makeClientKeyShare Context
ctx Group
grp
                      forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ GroupPrivate -> HandshakeM ()
setGroupPrivate GroupPrivate
cpri
                      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [KeyShareEntry] -> KeyShare
KeyShareClientHello [KeyShareEntry
ent]
          | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        sessionAndCipherToResume13 :: Maybe (ByteString, SessionData, Cipher)
sessionAndCipherToResume13 = do
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
tls13
            (ByteString
sid, SessionData
sdata) <- ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SessionData -> Version
sessionVersion SessionData
sdata forall a. Ord a => a -> a -> Bool
>= Version
TLS13)
            Cipher
sCipher <- 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
            forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
sid, SessionData
sdata, Cipher
sCipher)

        getPskInfo :: IO (Maybe (ByteString, SessionData, CipherChoice, Word32))
getPskInfo =
            case Maybe (ByteString, SessionData, Cipher)
sessionAndCipherToResume13 of
                Maybe (ByteString, SessionData, Cipher)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just (ByteString
sid, SessionData
sdata, Cipher
sCipher) -> do
                    let tinfo :: TLS13TicketInfo
tinfo = forall a. String -> Maybe a -> a
fromJust String
"sessionTicketInfo" forall a b. (a -> b) -> a -> b
$ SessionData -> Maybe TLS13TicketInfo
sessionTicketInfo SessionData
sdata
                    Word32
age <- TLS13TicketInfo -> IO Word32
getAge TLS13TicketInfo
tinfo
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Word32 -> TLS13TicketInfo -> Bool
isAgeValid Word32
age TLS13TicketInfo
tinfo
                        then forall a. a -> Maybe a
Just (ByteString
sid, SessionData
sdata, Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
sCipher, Word32 -> TLS13TicketInfo -> Word32
ageToObfuscatedAge Word32
age TLS13TicketInfo
tinfo)
                        else forall a. Maybe a
Nothing

        preSharedKeyExtension :: Maybe (ByteString, b, CipherChoice, Word32)
-> m (Maybe ExtensionRaw)
preSharedKeyExtension Maybe (ByteString, b, CipherChoice, Word32)
pskInfo =
            case Maybe (ByteString, b, CipherChoice, Word32)
pskInfo of
                Maybe (ByteString, b, CipherChoice, Word32)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                Just (ByteString
sid, b
_, CipherChoice
choice, Word32
obfAge) ->
                    let zero :: ByteString
zero = CipherChoice -> ByteString
cZero CipherChoice
choice
                        identity :: PskIdentity
identity = ByteString -> Word32 -> PskIdentity
PskIdentity ByteString
sid Word32
obfAge
                        offeredPsks :: PreSharedKey
offeredPsks = [PskIdentity] -> [ByteString] -> PreSharedKey
PreSharedKeyClientHello [PskIdentity
identity] [ByteString
zero]
                     in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw PreSharedKey
offeredPsks

        pskExchangeModeExtension :: IO (Maybe ExtensionRaw)
pskExchangeModeExtension
          | Bool
tls13     = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw forall a b. (a -> b) -> a -> b
$ [PskKexMode] -> PskKeyExchangeModes
PskKeyExchangeModes [PskKexMode
PSK_DHE_KE]
          | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        earlyDataExtension :: Bool -> m (Maybe ExtensionRaw)
earlyDataExtension Bool
rtt0
          | Bool
rtt0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (Maybe Word32 -> EarlyDataIndication
EarlyDataIndication forall a. Maybe a
Nothing)
          | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        cookieExtension :: IO (Maybe ExtensionRaw)
cookieExtension = do
            Maybe Cookie
mcookie <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Cookie)
getTLS13Cookie
            case Maybe Cookie
mcookie of
              Maybe Cookie
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
              Just Cookie
cookie -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw Cookie
cookie

        postHandshakeAuthExtension :: IO (Maybe ExtensionRaw)
postHandshakeAuthExtension
          | Context -> Bool
ctxQUICMode Context
ctx = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          | Bool
tls13           = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Extension e => e -> ExtensionRaw
toExtensionRaw PostHandshakeAuth
PostHandshakeAuth
          | Bool
otherwise       = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

        adjustExtentions :: Maybe (a, SessionData, CipherChoice, d)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
adjustExtentions Maybe (a, SessionData, CipherChoice, d)
pskInfo [ExtensionRaw]
exts Handshake
ch =
            case Maybe (a, SessionData, CipherChoice, d)
pskInfo of
                Maybe (a, SessionData, CipherChoice, d)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionRaw]
exts
                Just (a
_, SessionData
sdata, CipherChoice
choice, d
_) -> do
                      let psk :: ByteString
psk = SessionData -> ByteString
sessionSecret SessionData
sdata
                          earlySecret :: BaseSecret EarlySecret
earlySecret = CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice (forall a. a -> Maybe a
Just ByteString
psk)
                      forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ BaseSecret EarlySecret -> HandshakeM ()
setTLS13EarlySecret BaseSecret EarlySecret
earlySecret
                      let ech :: ByteString
ech = Handshake -> ByteString
encodeHandshake Handshake
ch
                          h :: Hash
h = CipherChoice -> Hash
cHash CipherChoice
choice
                          siz :: Int
siz = Hash -> Int
hashDigestSize Hash
h
                      ByteString
binder <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
h (Int
siz forall a. Num a => a -> a -> a
+ Int
3) (forall a. a -> Maybe a
Just ByteString
ech)
                      let exts' :: [ExtensionRaw]
exts' = forall a. [a] -> [a]
init [ExtensionRaw]
exts forall a. [a] -> [a] -> [a]
++ [ExtensionRaw -> ExtensionRaw
adjust (forall a. [a] -> a
last [ExtensionRaw]
exts)]
                          adjust :: ExtensionRaw -> ExtensionRaw
adjust (ExtensionRaw ExtensionID
eid ByteString
withoutBinders) = ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
eid ByteString
withBinders
                            where
                              withBinders :: ByteString
withBinders = ByteString -> ByteString -> ByteString
replacePSKBinder ByteString
withoutBinders ByteString
binder
                      forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionRaw]
exts'

        generateClientHelloParams :: IO (ClientRandom, Session)
generateClientHelloParams =
            case Maybe (ClientRandom, Session, Version)
mparams of
                -- Client random and session in the second client hello for
                -- retry must be the same as the first one.
                Just (ClientRandom
crand, Session
clientSession, Version
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
clientSession)
                Maybe (ClientRandom, Session, Version)
Nothing -> do
                    ClientRandom
crand <- Context -> IO ClientRandom
clientRandom Context
ctx
                    let paramSession :: Session
paramSession = case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
                            Maybe (ByteString, SessionData)
Nothing -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
                            Just (ByteString
sid, SessionData
sdata)
                                | SessionData -> Version
sessionVersion SessionData
sdata forall a. Ord a => a -> a -> Bool
>= Version
TLS13     -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
                                | EMSMode
ems forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS Bool -> Bool -> Bool
&& Bool
noSessionEMS -> Maybe ByteString -> Session
Session forall a. Maybe a
Nothing
                                | Bool
otherwise                         -> Maybe ByteString -> Session
Session (forall a. a -> Maybe a
Just ByteString
sid)
                              where noSessionEMS :: Bool
noSessionEMS = SessionFlag
SessionEMS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` SessionData -> [SessionFlag]
sessionFlags SessionData
sdata
                    -- In compatibility mode a client not offering a pre-TLS 1.3
                    -- session MUST generate a new 32-byte value
                    if Bool
tls13 Bool -> Bool -> Bool
&& Session
paramSession forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Session
Session forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
                        then do
                            Session
randomSession <- Context -> IO Session
newSession Context
ctx
                            forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
randomSession)
                        else forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
paramSession)

        sendClientHello :: Session -> ClientRandom -> IO (Bool, [ExtensionID])
sendClientHello Session
clientSession ClientRandom
crand = do
            let ver :: Version
ver = if Bool
tls13 then Version
TLS12 else Version
highestVer
            Bool
hrr <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr forall a b. (a -> b) -> a -> b
$ Context -> Version -> ClientRandom -> IO ()
startHandshake Context
ctx Version
ver ClientRandom
crand
            forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersionIfUnset Version
highestVer
            let cipherIds :: [ExtensionID]
cipherIds = forall a b. (a -> b) -> [a] -> [b]
map Cipher -> ExtensionID
cipherID [Cipher]
ciphers
                compIds :: [CompressionID]
compIds = forall a b. (a -> b) -> [a] -> [b]
map Compression -> CompressionID
compressionID [Compression]
compressions
                mkClientHello :: [ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
exts = Version
-> ClientRandom
-> Session
-> [ExtensionID]
-> [CompressionID]
-> [ExtensionRaw]
-> Maybe ByteString
-> Handshake
ClientHello Version
ver ClientRandom
crand Session
clientSession [ExtensionID]
cipherIds [CompressionID]
compIds [ExtensionRaw]
exts forall a. Maybe a
Nothing
            Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo <- IO (Maybe (ByteString, SessionData, CipherChoice, Word32))
getPskInfo
            let rtt0info :: Maybe (CipherChoice, ByteString)
rtt0info = Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} {a} {d}. (a, SessionData, a, d) -> Maybe (a, ByteString)
get0RTTinfo
                rtt0 :: Bool
rtt0 = forall a. Maybe a -> Bool
isJust Maybe (CipherChoice, ByteString)
rtt0info
            [ExtensionRaw]
extensions0 <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}.
Maybe (ByteString, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo Bool
rtt0
            let extensions1 :: [ExtensionRaw]
extensions1 = Shared -> [ExtensionRaw]
sharedHelloExtensions (ClientParams -> Shared
clientShared ClientParams
cparams) forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
extensions0
            [ExtensionRaw]
extensions <- forall {a} {d}.
Maybe (a, SessionData, CipherChoice, d)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
adjustExtentions Maybe (ByteString, SessionData, CipherChoice, Word32)
pskInfo [ExtensionRaw]
extensions1 forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions1
            Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [[ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions]
            Maybe EarlySecretInfo
mEarlySecInfo <- case Maybe (CipherChoice, ByteString)
rtt0info of
               Maybe (CipherChoice, ByteString)
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
               Just (CipherChoice, ByteString)
info -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CipherChoice, ByteString) -> IO EarlySecretInfo
send0RTT (CipherChoice, ByteString)
info
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr forall a b. (a -> b) -> a -> b
$ Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe EarlySecretInfo -> ClientState
SendClientHello Maybe EarlySecretInfo
mEarlySecInfo
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
rtt0, forall a b. (a -> b) -> [a] -> [b]
map (\(ExtensionRaw ExtensionID
i ByteString
_) -> ExtensionID
i) [ExtensionRaw]
extensions)

        get0RTTinfo :: (a, SessionData, a, d) -> Maybe (a, ByteString)
get0RTTinfo (a
_, SessionData
sdata, a
choice, d
_) = do
            ByteString
earlyData <- ClientParams -> Maybe ByteString
clientEarlyData ClientParams
cparams
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ByteString -> Int
B.length ByteString
earlyData forall a. Ord a => a -> a -> Bool
<= SessionData -> Int
sessionMaxEarlyDataSize SessionData
sdata)
            forall (m :: * -> *) a. Monad m => a -> m a
return (a
choice, ByteString
earlyData)

        send0RTT :: (CipherChoice, ByteString) -> IO EarlySecretInfo
send0RTT (CipherChoice
choice, ByteString
earlyData) = do
                let usedCipher :: Cipher
usedCipher = CipherChoice -> Cipher
cCipher CipherChoice
choice
                    usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
                Just BaseSecret EarlySecret
earlySecret <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret EarlySecret))
getTLS13EarlySecret
                -- Client hello is stored in hstHandshakeDigest
                -- But HandshakeDigestContext is not created yet.
                SecretPair EarlySecret
earlyKey <- Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (forall a b. b -> Either a b
Right BaseSecret EarlySecret
earlySecret) Bool
False
                let clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$ do
                    forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
                    forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
                    let len :: Maybe Int
len = Context -> Maybe Int
ctxFragmentSize Context
ctx
                    forall (m :: * -> *) a.
Monad m =>
Maybe Int -> (ByteString -> m a) -> ByteString -> m ()
mapChunks_ Maybe Int
len (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Packet13
AppData13) ByteString
earlyData
                -- We set RTT0Sent even in quicMode
                forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Sent
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
EarlySecretInfo Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret

        recvServerHello :: Session -> [ExtensionID] -> IO ()
recvServerHello Session
clientSession [ExtensionID]
sentExts = Context -> RecvState IO -> IO ()
runRecvState Context
ctx RecvState IO
recvState
          where recvState :: RecvState IO
recvState = forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext forall a b. (a -> b) -> a -> b
$ \Packet
p ->
                    case Packet
p of
                        Handshake [Handshake]
hs -> Context -> RecvState IO -> [Handshake] -> IO (RecvState IO)
onRecvStateHandshake Context
ctx (forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake forall a b. (a -> b) -> a -> b
$ Context
-> ClientParams
-> Session
-> [ExtensionID]
-> Handshake
-> IO (RecvState IO)
onServerHello Context
ctx ClientParams
cparams Session
clientSession [ExtensionID]
sentExts) [Handshake]
hs -- this adds SH to hstHandshakeMessages
                        Alert [(AlertLevel, AlertDescription)]
a      ->
                            case [(AlertLevel, AlertDescription)]
a of
                                [(AlertLevel
AlertLevel_Warning, AlertDescription
UnrecognizedName)] ->
                                    if ClientParams -> Bool
clientUseServerNameIndication ClientParams
cparams
                                        then forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
                                        else forall {m :: * -> *} {a} {a}. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
                                [(AlertLevel, AlertDescription)]
_ -> forall {m :: * -> *} {a} {a}. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
                        Packet
_ -> 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
"handshake")
                throwAlert :: a -> m a
throwAlert a
a = forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"expecting server hello, got alert : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
a, Bool
True, AlertDescription
HandshakeFailure)

-- | Store the keypair and check that it is compatible with the current protocol
-- version and a list of 'CertificateType' values.
storePrivInfoClient :: Context
                    -> [CertificateType]
                    -> Credential
                    -> IO ()
storePrivInfoClient :: Context -> [CertificateType] -> Credential -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes (CertificateChain
cc, PrivKey
privkey) = do
    PubKey
pubkey <- forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey -> [CertificateType] -> Bool
certificateCompatible PubKey
pubkey [CertificateType]
cTypes) 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
            ( PubKey -> String
pubkeyType PubKey
pubkey forall a. [a] -> [a] -> [a]
++ String
" credential does not match allowed certificate types"
            , Bool
True
            , AlertDescription
InternalError )
    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
pubkey PubKey -> Version -> Bool
`versionCompatible` Version
ver) 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
            ( PubKey -> String
pubkeyType PubKey
pubkey forall a. [a] -> [a] -> [a]
++ String
" credential is not supported at version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
ver
            , Bool
True
            , AlertDescription
InternalError )

-- | When the server requests a client certificate, we try to
-- obtain a suitable certificate chain and private key via the
-- callback in the client parameters.  It is OK for the callback
-- to return an empty chain, in many cases the client certificate
-- is optional.  If the client wishes to abort the handshake for
-- lack of a suitable certificate, it can throw an exception in
-- the callback.
--
-- The return value is 'Nothing' when no @CertificateRequest@ was
-- received and no @Certificate@ message needs to be sent. An empty
-- chain means that an empty @Certificate@ message needs to be sent
-- to the server, naturally without a @CertificateVerify@.  A non-empty
-- 'CertificateChain' is the chain to send to the server along with
-- a corresponding 'CertificateVerify'.
--
-- With TLS < 1.2 the server's @CertificateRequest@ does not carry
-- a signature algorithm list.  It has a list of supported public
-- key signing algorithms in the @certificate_types@ field.  The
-- hash is implicit.  It is 'SHA1' for DSS and 'SHA1_MD5' for RSA.
--
-- With TLS == 1.2 the server's @CertificateRequest@ always has a
-- @supported_signature_algorithms@ list, as a fixed component of
-- the structure.  This list is (wrongly) overloaded to also limit
-- X.509 signatures in the client's certificate chain.  The BCP
-- strategy is to find a compatible chain if possible, but else
-- ignore the constraint, and let the server verify the chain as it
-- sees fit.  The @supported_signature_algorithms@ field is only
-- obligatory with respect to signatures on TLS messages, in this
-- case the @CertificateVerify@ message.  The @certificate_types@
-- field is still included.
--
-- With TLS 1.3 the server's @CertificateRequest@ has a mandatory
-- @signature_algorithms@ extension, the @signature_algorithms_cert@
-- extension, which is optional, carries a list of algorithms the
-- server promises to support in verifying the certificate chain.
-- As with TLS 1.2, the client's makes a /best-effort/ to deliver
-- a compatible certificate chain where all the CA signatures are
-- known to be supported, but it should not abort the connection
-- just because the chain might not work out, just send the best
-- chain you have and let the server worry about the rest.  The
-- supported public key algorithms are now inferred from the
-- @signature_algorithms@ extension and @certificate_types@ is
-- gone.
--
-- With TLS 1.3, we synthesize and store a @certificate_types@
-- field at the time that the server's @CertificateRequest@
-- message is received.  This is then present across all the
-- protocol versions, and can be used to determine whether
-- a @CertificateRequest@ was received or not.
--
-- If @signature_algorithms@ is 'Nothing', then we're doing
-- TLS 1.0 or 1.1.  The @signature_algorithms_cert@ extension
-- is optional in TLS 1.3, and so the application callback
-- will not be able to distinguish between TLS 1.[01] and
-- TLS 1.3 with no certificate algorithm hints, but this
-- just simplifies the chain selection process, all CA
-- signatures are OK.
--
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx =
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe CertReqCBdata
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just CertReqCBdata
cbdata -> do
            let callback :: OnCertificateRequest
callback = ClientHooks -> OnCertificateRequest
onCertificateRequest forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
            Maybe Credential
chain <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ OnCertificateRequest
callback CertReqCBdata
cbdata forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
                forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"certificate request callback failed"
            case Maybe Credential
chain of
                Maybe Credential
Nothing
                    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
                Just (CertificateChain [], PrivKey
_)
                    -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
                Just cred :: Credential
cred@(CertificateChain
cc, PrivKey
_)
                    -> do
                       let ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
_, [DistinguishedName]
_) = CertReqCBdata
cbdata
                       Context -> [CertificateType] -> Credential -> IO ()
storePrivInfoClient Context
ctx [CertificateType]
cTypes Credential
cred
                       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just CertificateChain
cc

-- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with
-- the local key and server's signature algorithms (both already saved).  Must
-- only be called for TLS versions 1.2 and up, with compatibility function
-- 'signatureCompatible' or 'signatureCompatible13' based on version.
--
-- The values in the server's @signature_algorithms@ extension are
-- in descending order of preference.  However here the algorithms
-- are selected by client preference in @cHashSigs@.
--
getLocalHashSigAlg :: Context
                   -> (PubKey -> HashAndSignatureAlgorithm -> Bool)
                   -> [HashAndSignatureAlgorithm]
                   -> PubKey
                   -> IO HashAndSignatureAlgorithm
getLocalHashSigAlg :: Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey = do
    -- Must be present with TLS 1.2 and up.
    (Just ([CertificateType]
_, Just [HashAndSignatureAlgorithm]
hashSigs, [DistinguishedName]
_)) <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata
    let want :: HashAndSignatureAlgorithm -> Bool
want = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible PubKey
pubKey
                    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [HashAndSignatureAlgorithm]
hashSigs
    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find HashAndSignatureAlgorithm -> Bool
want [HashAndSignatureAlgorithm]
cHashSigs of
        Just HashAndSignatureAlgorithm
best -> forall (m :: * -> *) a. Monad m => a -> m a
return HashAndSignatureAlgorithm
best
        Maybe HashAndSignatureAlgorithm
Nothing   -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
                         ( PubKey -> String
keyerr PubKey
pubKey
                         , Bool
True
                         , AlertDescription
HandshakeFailure
                         )
  where
    keyerr :: PubKey -> String
keyerr PubKey
k = String
"no " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
k forall a. [a] -> [a] -> [a]
++ String
" hash algorithm in common with the server"

-- | Return the supported 'CertificateType' values that are
-- compatible with at least one supported signature algorithm.
--
supportedCtypes :: [HashAndSignatureAlgorithm]
                -> [CertificateType]
supportedCtypes :: [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashAlgs =
    forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter [] [HashAndSignatureAlgorithm]
hashAlgs
  where
    ctfilter :: HashAndSignatureAlgorithm -> [CertificateType] -> [CertificateType]
ctfilter HashAndSignatureAlgorithm
x [CertificateType]
acc = case HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType HashAndSignatureAlgorithm
x of
       Just CertificateType
cType | CertificateType
cType forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType
                 -> CertificateType
cType forall a. a -> [a] -> [a]
: [CertificateType]
acc
       Maybe CertificateType
_         -> [CertificateType]
acc
--
clientSupportedCtypes :: Context
                      -> [CertificateType]
clientSupportedCtypes :: Context -> [CertificateType]
clientSupportedCtypes Context
ctx =
    [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
--
sigAlgsToCertTypes :: Context
                   -> [HashAndSignatureAlgorithm]
                   -> [CertificateType]
sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
hashSigs =
    forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashSigs) forall a b. (a -> b) -> a -> b
$ Context -> [CertificateType]
clientSupportedCtypes Context
ctx

-- | TLS 1.2 and below.  Send the client handshake messages that
-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@.
--
-- XXX: Is any buffering done here to combined these messages into
-- a single TCP packet?  Otherwise we're prone to Nagle delays, or
-- in any case needlessly generate multiple small packets, where
-- a single larger packet will do.  The TLS 1.3 code path seems
-- to separating record generation and transmission and sending
-- multiple records in a single packet.
--
--       -> [certificate]
--       -> client key exchange
--       -> [cert verify]
sendClientData :: ClientParams -> Context -> IO ()
sendClientData :: ClientParams -> Context -> IO ()
sendClientData ClientParams
cparams Context
ctx = IO ()
sendCertificate forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendClientKeyXchg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendCertificateVerify
  where
        sendCertificate :: IO ()
sendCertificate = do
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setClientCertSent Bool
False
            ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe CertificateChain
Nothing                    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just cc :: CertificateChain
cc@(CertificateChain [SignedExact Certificate]
certs) -> do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
certs) 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
$ Bool -> HandshakeM ()
setClientCertSent Bool
True
                    Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [CertificateChain -> Handshake
Certificates CertificateChain
cc]

        sendClientKeyXchg :: IO ()
sendClientKeyXchg = do
            Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
            (ClientKeyXchgAlgorithmData
ckx, HandshakeM ByteString
setMasterSec) <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
                CipherKeyExchangeType
CipherKeyExchange_RSA -> do
                    Version
clientVersion <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Version
hstClientVersion
                    (Version
xver, ByteString
prerand) <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Version
getVersion forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TLSSt ByteString
genRandom Int
46

                    let premaster :: ByteString
premaster = Version -> ByteString -> ByteString
encodePreMasterSecret Version
clientVersion ByteString
prerand
                        setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole ByteString
premaster
                    ByteString
encryptedPreMaster <- do
                        -- SSL3 implementation generally forget this length field since it's redundant,
                        -- however TLS10 make it clear that the length field need to be present.
                        ByteString
e <- Context -> ByteString -> IO ByteString
encryptRSA Context
ctx ByteString
premaster
                        let extra :: ByteString
extra = if Version
xver forall a. Ord a => a -> a -> Bool
< Version
TLS10
                                        then ByteString
B.empty
                                        else ExtensionID -> ByteString
encodeWord16 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
e
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString
extra ByteString -> ByteString -> ByteString
`B.append` ByteString
e
                    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ClientKeyXchgAlgorithmData
CKX_RSA ByteString
encryptedPreMaster, HandshakeM ByteString
setMasterSec)
                CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE
                CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE
                CipherKeyExchangeType
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"client key exchange unsupported type", Bool
True, AlertDescription
HandshakeFailure)
            Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [ClientKeyXchgAlgorithmData -> Handshake
ClientKeyXchg ClientKeyXchgAlgorithmData
ckx]
            ByteString
masterSecret <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ByteString
setMasterSec
            forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
          where getCKX_DHE :: IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE = do
                    Version
xver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
                    ServerDHParams
serverParams <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerDHParams
getServerDHParams

                    let params :: DHParams
params  = ServerDHParams -> DHParams
serverDHParamsToParams ServerDHParams
serverParams
                        ffGroup :: Maybe Group
ffGroup = DHParams -> Maybe Group
findFiniteFieldGroup DHParams
params
                        srvpub :: DHPublic
srvpub  = ServerDHParams -> DHPublic
serverDHParamsToPublic ServerDHParams
serverParams

                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Context -> Group -> Bool
isSupportedGroup Context
ctx) Maybe Group
ffGroup) forall a b. (a -> b) -> a -> b
$ do
                        GroupUsage
groupUsage <- ClientHooks -> DHParams -> DHPublic -> IO GroupUsage
onCustomFFDHEGroup (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) DHParams
params DHPublic
srvpub forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
                                          forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"custom group callback failed"
                        case GroupUsage
groupUsage of
                            GroupUsage
GroupUsageInsecure           -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"FFDHE group is not secure enough", Bool
True, AlertDescription
InsufficientSecurity)
                            GroupUsageUnsupported String
reason -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unsupported FFDHE group: " forall a. [a] -> [a] -> [a]
++ String
reason, Bool
True, AlertDescription
HandshakeFailure)
                            GroupUsage
GroupUsageInvalidPublic      -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server public key", Bool
True, AlertDescription
IllegalParameter)
                            GroupUsage
GroupUsageValid              -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

                    -- When grp is known but not in the supported list we use it
                    -- anyway.  This provides additional validation and a more
                    -- efficient implementation.
                    (DHPublic
clientDHPub, DHKey
premaster) <-
                        case Maybe Group
ffGroup of
                             Maybe Group
Nothing  -> do
                                 (DHPrivate
clientDHPriv, DHPublic
clientDHPub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
params
                                 let premaster :: DHKey
premaster = DHParams -> DHPrivate -> DHPublic -> DHKey
dhGetShared DHParams
params DHPrivate
clientDHPriv DHPublic
srvpub
                                 forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic
clientDHPub, DHKey
premaster)
                             Just 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
                                 Maybe (DHPublic, DHKey)
dhePair <- Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))
generateFFDHEShared Context
ctx Group
grp DHPublic
srvpub
                                 case Maybe (DHPublic, DHKey)
dhePair of
                                     Maybe (DHPublic, DHKey)
Nothing   -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp forall a. [a] -> [a] -> [a]
++ String
" public key", Bool
True, AlertDescription
IllegalParameter)
                                     Just (DHPublic, DHKey)
pair -> forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic, DHKey)
pair

                    let setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole DHKey
premaster
                    forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic -> ClientKeyXchgAlgorithmData
CKX_DH DHPublic
clientDHPub, HandshakeM ByteString
setMasterSec)

                getCKX_ECDHE :: IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE = do
                    ServerECDHParams Group
grp GroupPublic
srvpub <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerECDHParams
getServerECDHParams
                    Context -> Group -> IO ()
checkSupportedGroup Context
ctx Group
grp
                    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
                    Maybe (GroupPublic, GroupKey)
ecdhePair <- Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))
generateECDHEShared Context
ctx GroupPublic
srvpub
                    case Maybe (GroupPublic, GroupKey)
ecdhePair of
                        Maybe (GroupPublic, GroupKey)
Nothing                  -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Group
grp forall a. [a] -> [a] -> [a]
++ String
" public key", Bool
True, AlertDescription
IllegalParameter)
                        Just (GroupPublic
clipub, GroupKey
premaster) -> do
                            Version
xver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
                            let setMasterSec :: HandshakeM ByteString
setMasterSec = forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM ByteString
setMasterSecretFromPre Version
xver Role
ClientRole GroupKey
premaster
                            forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ClientKeyXchgAlgorithmData
CKX_ECDH forall a b. (a -> b) -> a -> b
$ GroupPublic -> ByteString
encodeGroupPublic GroupPublic
clipub, HandshakeM ByteString
setMasterSec)

        -- In order to send a proper certificate verify message,
        -- we have to do the following:
        --
        -- 1. Determine which signing algorithm(s) the server supports
        --    (we currently only support RSA).
        -- 2. Get the current handshake hash from the handshake state.
        -- 3. Sign the handshake hash
        -- 4. Send it to the server.
        --
        sendCertificateVerify :: IO ()
sendCertificateVerify = do
            Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion

            -- Only send a certificate verify message when we
            -- have sent a non-empty list of certificates.
            --
            Bool
certSent <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getClientCertSent
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
certSent forall a b. (a -> b) -> a -> b
$ do
                PubKey
pubKey      <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
                Maybe HashAndSignatureAlgorithm
mhashSig    <- case Version
ver of
                    Version
TLS12 ->
                        let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                         in forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
signatureCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey
                    Version
_     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

                -- 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
                DigitallySigned
sigDig <- Context
-> Version
-> PubKey
-> Maybe HashAndSignatureAlgorithm
-> ByteString
-> IO DigitallySigned
createCertificateVerify Context
ctx Version
ver PubKey
pubKey Maybe HashAndSignatureAlgorithm
mhashSig ByteString
msgs
                Context -> Packet -> IO ()
sendPacket Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [DigitallySigned -> Handshake
CertVerify DigitallySigned
sigDig]

processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension (ExtensionRaw ExtensionID
extID ByteString
content)
  | ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SecureRenegotiation = do
        ByteString
cv <- Role -> TLSSt ByteString
getVerifiedData Role
ClientRole
        ByteString
sv <- Role -> TLSSt ByteString
getVerifiedData Role
ServerRole
        let bs :: ByteString
bs = forall a. Extension a => a -> ByteString
extensionEncode (ByteString -> Maybe ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cv forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
sv)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bs ByteString -> ByteString -> Bool
`bytesEq` ByteString
content) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server secure renegotiation data not matching", Bool
True, AlertDescription
HandshakeFailure)
  | ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SupportedVersions = case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content of
      Just (SupportedVersionsServerHello Version
ver) -> Version -> TLSSt ()
setVersion Version
ver
      Maybe SupportedVersions
_                                       -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_KeyShare = do
        Bool
hrr <- TLSSt Bool
getTLS13HRR
        let msgt :: MessageType
msgt = if Bool
hrr then MessageType
MsgTHelloRetryRequest else MessageType
MsgTServerHello
        Maybe KeyShare -> TLSSt ()
setTLS13KeyShare forall a b. (a -> b) -> a -> b
$ forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
msgt ByteString
content
  | ExtensionID
extID forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_PreSharedKey =
        Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey forall a b. (a -> b) -> a -> b
$ forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content
processServerExtension ExtensionRaw
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException :: forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
msg SomeException
e =
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc forall a b. (a -> b) -> a -> b
$ String
msg forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e

-- | onServerHello process the ServerHello message on the client.
--
-- 1) check the version chosen by the server is one allowed by parameters.
-- 2) check that our compression and cipher algorithms are part of the list we sent
-- 3) check extensions received are part of the one we sent
-- 4) process the session parameter to see if the server want to start a new session or can resume
-- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher
--
onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO)
onServerHello :: Context
-> ClientParams
-> Session
-> [ExtensionID]
-> Handshake
-> IO (RecvState IO)
onServerHello Context
ctx ClientParams
cparams Session
clientSession [ExtensionID]
sentExts (ServerHello Version
rver ServerRandom
serverRan Session
serverSession ExtensionID
cipher CompressionID
compression [ExtensionRaw]
exts) = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
rver 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
"SSL2 is not supported", Bool
True, AlertDescription
ProtocolVersion)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
rver 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
"SSL3 is not supported", Bool
True, AlertDescription
ProtocolVersion)
    -- find the compression and cipher methods that the server want to use.
    Cipher
cipherAlg <- case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) ExtensionID
cipher forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) (Supported -> [Cipher]
supportedCiphers forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
                     Maybe Cipher
Nothing  -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server choose unknown cipher", Bool
True, AlertDescription
IllegalParameter)
                     Just Cipher
alg -> forall (m :: * -> *) a. Monad m => a -> m a
return Cipher
alg
    Compression
compressAlg <- case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
(==) CompressionID
compression forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compression -> CompressionID
compressionID) (Supported -> [Compression]
supportedCompressions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
                       Maybe Compression
Nothing  -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server choose unknown compression", Bool
True, AlertDescription
IllegalParameter)
                       Just Compression
alg -> forall (m :: * -> *) a. Monad m => a -> m a
return Compression
alg

    -- intersect sent extensions in client and the received extensions from server.
    -- if server returns extensions that we didn't request, fail.
    let checkExt :: ExtensionRaw -> Bool
checkExt (ExtensionRaw ExtensionID
i ByteString
_)
          | ExtensionID
i forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_Cookie = Bool
False -- for HRR
          | Bool
otherwise               = ExtensionID
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
sentExts
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExtensionRaw -> Bool
checkExt [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
"spurious extensions received", Bool
True, AlertDescription
UnsupportedExtension)

    let resumingSession :: Maybe SessionData
resumingSession =
            case ClientParams -> Maybe (ByteString, SessionData)
clientWantSessionResume ClientParams
cparams of
                Just (ByteString
sessionId, SessionData
sessionData) -> if Session
serverSession forall a. Eq a => a -> a -> Bool
== Maybe ByteString -> Session
Session (forall a. a -> Maybe a
Just ByteString
sessionId) then forall a. a -> Maybe a
Just SessionData
sessionData else forall a. Maybe a
Nothing
                Maybe (ByteString, SessionData)
Nothing                       -> forall a. Maybe a
Nothing
        isHRR :: Bool
isHRR = ServerRandom -> Bool
isHelloRetryRequest ServerRandom
serverRan
    forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
        Bool -> TLSSt ()
setTLS13HRR Bool
isHRR
        Maybe Cookie -> TLSSt ()
setTLS13Cookie (forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isHRR forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_Cookie [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
MsgTServerHello)
        Session -> Bool -> TLSSt ()
setSession Session
serverSession (forall a. Maybe a -> Bool
isJust Maybe SessionData
resumingSession)
        Version -> TLSSt ()
setVersion Version
rver -- must be before processing supportedVersions ext
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ExtensionRaw -> TLSSt ()
processServerExtension [ExtensionRaw]
exts

    Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTServerHello [ExtensionRaw]
exts

    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion

    -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3
    -- in the supported_versions extension, *AND ALSO* set the TLS 1.2
    -- downgrade signal in the server random.  If we support TLS 1.3 and
    -- actually negotiate TLS 1.3, we must ignore the server random downgrade
    -- signal.  Therefore, 'isDowngraded' needs to take into account the
    -- negotiated version and the server random, as well as the list of
    -- client-side enabled protocol versions.
    --
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> [Version] -> ServerRandom -> Bool
isDowngraded Version
ver (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams) ServerRandom
serverRan) 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
"version downgrade detected", Bool
True, AlertDescription
IllegalParameter)

    case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Version
ver) (Supported -> [Version]
supportedVersions forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) 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
"server version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
ver forall a. [a] -> [a] -> [a]
++ String
" is not supported", Bool
True, AlertDescription
ProtocolVersion)
        Just Version
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    if Version
ver forall a. Ord a => a -> a -> Bool
> Version
TLS12 then do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Session
serverSession forall a. Eq a => a -> a -> Bool
/= Session
clientSession) 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
"received mismatched legacy session", Bool
True, AlertDescription
IllegalParameter)
        Established
established <- Context -> IO Established
ctxEstablished Context
ctx
        Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) 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 to TLS 1.3 or later is not allowed", Bool
True, AlertDescription
ProtocolVersion)
        forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression
        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
cipherAlg
        forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). RecvState m
RecvStateDone
      else do
        Bool
ems <- forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMasterSec Context
ctx Version
ver MessageType
MsgTServerHello [ExtensionRaw]
exts
        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
rver ServerRandom
serverRan Cipher
cipherAlg Compression
compressAlg
        case Maybe SessionData
resumingSession of
            Maybe SessionData
Nothing          -> 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 (ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx)
            Just SessionData
sessionData -> do
                let emsSession :: Bool
emsSession = SessionFlag
SessionEMS forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SessionData -> [SessionFlag]
sessionFlags SessionData
sessionData
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ems forall a. Eq a => a -> a -> Bool
/= Bool
emsSession) forall a b. (a -> b) -> a -> b
$
                    let err :: String
err = String
"server resumes a session which is not EMS consistent"
                     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)
                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
rver Role
ClientRole ByteString
masterSecret
                forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MasterSecret
MasterSecret ByteString
masterSecret)
                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 Packet -> IO (RecvState IO)
expectChangeCipher
onServerHello Context
_ ClientParams
_ Session
_ [ExtensionID]
_ 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
"server hello")

processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx (Certificates CertificateChain
certs) = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs) 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
"server certificate missing", Bool
True, AlertDescription
DecodeError)
    -- run certificate recv hook
    forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Hooks -> CertificateChain -> IO ()
`hookRecvCertificates` CertificateChain
certs)
    -- then run certificate validation
    CertificateUsage
usage <- forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([FailedReason] -> CertificateUsage
wrapCertificateChecks forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FailedReason]
checkCert) SomeException -> IO CertificateUsage
rejectOnException
    case CertificateUsage
usage of
        CertificateUsage
CertificateUsageAccept        -> IO ()
checkLeafCertificateKeyUsage
        CertificateUsageReject CertificateRejectReason
reason -> forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason
    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 (Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx)
  where shared :: Shared
shared = ClientParams -> Shared
clientShared ClientParams
cparams
        checkCert :: IO [FailedReason]
checkCert = ClientHooks -> OnServerCertificate
onServerCertificate (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) (Shared -> CertificateStore
sharedCAStore Shared
shared)
                                                              (Shared -> ValidationCache
sharedValidationCache Shared
shared)
                                                              (ClientParams -> (String, ByteString)
clientServerIdentification ClientParams
cparams)
                                                              CertificateChain
certs
        -- also verify that the certificate optional key usage is compatible
        -- with the intended key-exchange.  This check is not delegated to
        -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated
        -- cipher, which is not available from onServerCertificate parameters.
        -- Additionally, with only one shared ValidationCache, x509-validation
        -- would cache validation result based on a key usage and reuse it with
        -- another key usage.
        checkLeafCertificateKeyUsage :: IO ()
checkLeafCertificateKeyUsage = do
            Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
            case Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher of
                []    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [ExtKeyUsageFlag]
flags -> forall (m :: * -> *).
MonadIO m =>
[ExtKeyUsageFlag] -> CertificateChain -> m ()
verifyLeafKeyUsage [ExtKeyUsageFlag]
flags CertificateChain
certs

processCertificate ClientParams
_ Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx Handshake
p

expectChangeCipher :: Packet -> IO (RecvState IO)
expectChangeCipher :: Packet -> IO (RecvState IO)
expectChangeCipher Packet
ChangeCipherSpec = 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 Handshake -> IO (RecvState IO)
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 -> IO (RecvState IO)
expectFinish :: Handshake -> IO (RecvState IO)
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")

processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx (ServerKeyXchg ServerKeyXchgAlgorithmData
origSkx) = do
    Cipher
cipher <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
origSkx
    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 (Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx)
  where processWithCipher :: Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
skx =
            case (Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher, ServerKeyXchgAlgorithmData
skx) of
                (CipherKeyExchangeType
CipherKeyExchange_DHE_RSA, SKX_DHE_RSA ServerDHParams
dhparams DigitallySigned
signature) ->
                    ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
                (CipherKeyExchangeType
CipherKeyExchange_DHE_DSS, SKX_DHE_DSS ServerDHParams
dhparams DigitallySigned
signature) ->
                    ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_DSS
                (CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
                    ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_RSA
                (CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ServerECDHParams
ecdhparams DigitallySigned
signature) ->
                    ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
KX_ECDSA
                (CipherKeyExchangeType
cke, SKX_Unparsed ByteString
bytes) -> do
                    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
                    case Version
-> CipherKeyExchangeType
-> ByteString
-> Either TLSError ServerKeyXchgAlgorithmData
decodeReallyServerKeyXchgAlgorithmData Version
ver CipherKeyExchangeType
cke ByteString
bytes of
                        Left TLSError
_        -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CipherKeyExchangeType
cke, Bool
True, AlertDescription
HandshakeFailure)
                        Right ServerKeyXchgAlgorithmData
realSkx -> Cipher -> ServerKeyXchgAlgorithmData -> IO ()
processWithCipher Cipher
cipher ServerKeyXchgAlgorithmData
realSkx
                    -- we need to resolve the result. and recall processWithCipher ..
                (CipherKeyExchangeType
c,ServerKeyXchgAlgorithmData
_)           -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CipherKeyExchangeType
c, Bool
True, AlertDescription
HandshakeFailure)
        doDHESignature :: ServerDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doDHESignature ServerDHParams
dhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
            -- FF group selected by the server is verified when generating CKX
            PubKey
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
            Bool
verified <- Context -> ServerDHParams -> PubKey -> DigitallySigned -> IO Bool
digitallySignDHParamsVerify Context
ctx ServerDHParams
dhparams PubKey
publicKey DigitallySigned
signature
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey forall a. [a] -> [a] -> [a]
++ String
" signature for dhparams " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ServerDHParams
dhparams)
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
dhparams

        doECDHESignature :: ServerECDHParams
-> DigitallySigned -> KeyExchangeSignatureAlg -> IO ()
doECDHESignature ServerECDHParams
ecdhparams DigitallySigned
signature KeyExchangeSignatureAlg
kxsAlg = do
            -- EC group selected by the server is verified when generating CKX
            PubKey
publicKey <- KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg
            Bool
verified <- Context -> ServerECDHParams -> PubKey -> DigitallySigned -> IO Bool
digitallySignECDHParamsVerify Context
ctx ServerECDHParams
ecdhparams PubKey
publicKey DigitallySigned
signature
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey forall a. [a] -> [a] -> [a]
++ String
" signature for ecdhparams")
            forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
ecdhparams

        getSignaturePublicKey :: KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg = do
            PubKey
publicKey <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyExchangeSignatureAlg -> PubKey -> Bool
isKeyExchangeSignatureKey KeyExchangeSignatureAlg
kxsAlg PubKey
publicKey) 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
"server public key algorithm is incompatible with " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg, Bool
True, AlertDescription
HandshakeFailure)
            Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
publicKey PubKey -> Version -> Bool
`versionCompatible` Version
ver) 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 (forall a. Show a => a -> String
show Version
ver forall a. [a] -> [a] -> [a]
++ String
" has no support for " forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey, Bool
True, AlertDescription
IllegalParameter)
            let groups :: [Group]
groups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Group -> Bool) -> PubKey -> Bool
satisfiesEcPredicate (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups) PubKey
publicKey) 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
"server public key has unsupported elliptic curve", Bool
True, AlertDescription
IllegalParameter)
            forall (m :: * -> *) a. Monad m => a -> m a
return PubKey
publicKey

processServerKeyExchange Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx Handshake
p

processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
processCertificateRequest Context
ctx (CertRequest [CertificateType]
cTypesSent Maybe [HashAndSignatureAlgorithm]
sigAlgs [DistinguishedName]
dNames) = do
    Version
ver <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver forall a. Eq a => a -> a -> Bool
== Version
TLS12 Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe [HashAndSignatureAlgorithm]
sigAlgs) 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
"missing TLS 1.2 certificate request signature algorithms"
            , Bool
True
            , AlertDescription
InternalError
            )
    let cTypes :: [CertificateType]
cTypes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType) [CertificateType]
cTypesSent
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
sigAlgs, [DistinguishedName]
dNames)
    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 :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx)
processCertificateRequest Context
ctx Handshake
p = do
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a. Maybe a
Nothing
    forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx Handshake
p

processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
processServerHelloDone :: forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
_ Handshake
ServerHelloDone = forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). RecvState m
RecvStateDone
processServerHelloDone Context
_ 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
"server hello data")

-- Unless result is empty, server certificate must be allowed for at least one
-- of the returned values.  Constraints for RSA-based key exchange are relaxed
-- to avoid rejecting certificates having incomplete extension.
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher =
    case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
        CipherKeyExchangeType
CipherKeyExchange_RSA         -> [ExtKeyUsageFlag]
rsaCompatibility
        CipherKeyExchangeType
CipherKeyExchange_DH_Anon     -> [] -- unrestricted
        CipherKeyExchangeType
CipherKeyExchange_DHE_RSA     -> [ExtKeyUsageFlag]
rsaCompatibility
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA   -> [ExtKeyUsageFlag]
rsaCompatibility
        CipherKeyExchangeType
CipherKeyExchange_DHE_DSS     -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
        CipherKeyExchangeType
CipherKeyExchange_DH_DSS      -> [ ExtKeyUsageFlag
KeyUsage_keyAgreement ]
        CipherKeyExchangeType
CipherKeyExchange_DH_RSA      -> [ExtKeyUsageFlag]
rsaCompatibility
        CipherKeyExchangeType
CipherKeyExchange_ECDH_ECDSA  -> [ ExtKeyUsageFlag
KeyUsage_keyAgreement ]
        CipherKeyExchangeType
CipherKeyExchange_ECDH_RSA    -> [ExtKeyUsageFlag]
rsaCompatibility
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
        CipherKeyExchangeType
CipherKeyExchange_TLS13       -> [ ExtKeyUsageFlag
KeyUsage_digitalSignature ]
  where rsaCompatibility :: [ExtKeyUsageFlag]
rsaCompatibility = [ ExtKeyUsageFlag
KeyUsage_digitalSignature
                           , ExtKeyUsageFlag
KeyUsage_keyEncipherment
                           , ExtKeyUsageFlag
KeyUsage_keyAgreement
                           ]

handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 ClientParams
cparams Context
ctx Maybe Group
groupSent = do
    CipherChoice
choice <- Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' ClientParams
cparams Context
ctx Maybe Group
groupSent CipherChoice
choice

handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' ClientParams
cparams Context
ctx Maybe Group
groupSent CipherChoice
choice = do
    (Cipher
_, SecretTriple HandshakeSecret
hkey, Bool
resuming) <- IO (Cipher, SecretTriple HandshakeSecret, Bool)
switchToHandshakeSecret
    let handshakeSecret :: BaseSecret HandshakeSecret
handshakeSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
hkey
        clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
clientHandshakeSecret = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
hkey
        serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
hkey
        handSecInfo :: HandshakeSecretInfo
handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
HandshakeSecretInfo Cipher
usedCipher (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret,ServerTrafficSecret HandshakeSecret
serverHandshakeSecret)
    Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ HandshakeSecretInfo -> ClientState
RecvServerHello HandshakeSecretInfo
handSecInfo
    (Bool
rtt0accepted,[ExtensionRaw]
eexts) <- forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 forall a b. (a -> b) -> a -> b
$ do
        (Bool, [ExtensionRaw])
accext <- forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> m (Bool, [ExtensionRaw])
expectEncryptedExtensions
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
resuming forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertRequest
        forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
MonadIO m =>
ServerTrafficSecret a -> ByteString -> Handshake13 -> m ()
expectFinished ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, [ExtensionRaw])
accext
    ByteString
hChSf <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) forall a b. (a -> b) -> a -> b
$
        forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
rtt0accepted Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)) forall a b. (a -> b) -> a -> b
$
        Context -> Packet13 -> IO ()
sendPacket13 Context
ctx ([Handshake13] -> Packet13
Handshake13 [Handshake13
EndOfEarlyData13])
    forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
    forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
    SecretTriple ApplicationSecret
appKey <- BaseSecret HandshakeSecret
-> ByteString -> IO (SecretTriple ApplicationSecret)
switchToApplicationSecret BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf
    let applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple ApplicationSecret
appKey
    BaseSecret ApplicationSecret -> IO ()
setResumptionSecret BaseSecret ApplicationSecret
applicationSecret
    let appSecInfo :: ApplicationSecretInfo
appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
ApplicationSecretInfo (forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey, forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey)
    Context -> ClientState -> IO ()
contextSync Context
ctx forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> ApplicationSecretInfo -> ClientState
SendClientFinished [ExtensionRaw]
eexts ApplicationSecretInfo
appSecInfo
    Context -> IO ()
handshakeTerminate13 Context
ctx
  where
    usedCipher :: Cipher
usedCipher = CipherChoice -> Cipher
cCipher CipherChoice
choice
    usedHash :: Hash
usedHash   = CipherChoice -> Hash
cHash CipherChoice
choice

    hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash

    switchToHandshakeSecret :: IO (Cipher, SecretTriple HandshakeSecret, Bool)
switchToHandshakeSecret = do
        forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
        ByteString
ecdhe <- IO ByteString
calcSharedKey
        (BaseSecret EarlySecret
earlySecret, Bool
resuming) <- IO (BaseSecret EarlySecret, Bool)
makeEarlySecret
        SecretTriple HandshakeSecret
handKey <- 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
        forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        forall (m :: * -> *) a. Monad m => a -> m a
return (Cipher
usedCipher, SecretTriple HandshakeSecret
handKey, Bool
resuming)

    switchToApplicationSecret :: BaseSecret HandshakeSecret
-> ByteString -> IO (SecretTriple ApplicationSecret)
switchToApplicationSecret BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf = do
        forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
        SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handshakeSecret ByteString
hChSf
        let serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
serverApplicationSecret0 = forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey
        let clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
        forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret ApplicationSecret
clientApplicationSecret0
        forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret ApplicationSecret
serverApplicationSecret0
        forall (m :: * -> *) a. Monad m => a -> m a
return SecretTriple ApplicationSecret
appKey

    calcSharedKey :: IO ByteString
calcSharedKey = do
        KeyShareEntry
serverKeyShare <- do
            Maybe KeyShare
mks <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
            case Maybe KeyShare
mks of
              Just (KeyShareServerHello KeyShareEntry
ks) -> forall (m :: * -> *) a. Monad m => a -> m a
return KeyShareEntry
ks
              Just KeyShare
_                        -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid key_share value", Bool
True, AlertDescription
IllegalParameter)
              Maybe KeyShare
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
HandshakeFailure)
        let grp :: Group
grp = KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
serverKeyShare
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyShareEntry -> Bool
checkKeyShareKeyLength KeyShareEntry
serverKeyShare) 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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Group
groupSent forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Group
grp) 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
"received incompatible group for (EC)DHE", Bool
True, AlertDescription
IllegalParameter)
        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
        forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM GroupPrivate
getGroupPrivate forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyShareEntry -> GroupPrivate -> IO ByteString
fromServerKeyShare KeyShareEntry
serverKeyShare

    makeEarlySecret :: IO (BaseSecret EarlySecret, Bool)
makeEarlySecret = do
         Maybe (BaseSecret EarlySecret)
mEarlySecretPSK <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe (BaseSecret EarlySecret))
getTLS13EarlySecret
         case Maybe (BaseSecret EarlySecret)
mEarlySecretPSK of
           Maybe (BaseSecret EarlySecret)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice forall a. Maybe a
Nothing, Bool
False)
           Just earlySecretPSK :: BaseSecret EarlySecret
earlySecretPSK@(BaseSecret ByteString
sec) -> do
               Maybe PreSharedKey
mSelectedIdentity <- forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe PreSharedKey)
getTLS13PreSharedKey
               case Maybe PreSharedKey
mSelectedIdentity of
                 Maybe PreSharedKey
Nothing                          ->
                     forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice forall a. Maybe a
Nothing, Bool
False)
                 Just (PreSharedKeyServerHello Int
0) -> do
                     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Int
B.length ByteString
sec forall a. Eq a => a -> a -> Bool
== Int
hashSize) 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
"selected cipher is incompatible with selected PSK", Bool
True, AlertDescription
IllegalParameter)
                     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
                     forall (m :: * -> *) a. Monad m => a -> m a
return (BaseSecret EarlySecret
earlySecretPSK, Bool
True)
                 Just PreSharedKey
_                           -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"selected identity out of range", Bool
True, AlertDescription
IllegalParameter)

    expectEncryptedExtensions :: Handshake13 -> m (Bool, [ExtensionRaw])
expectEncryptedExtensions (EncryptedExtensions13 [ExtensionRaw]
eexts) = do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTEncryptedExtensions [ExtensionRaw]
eexts
        RTT0Status
st <- forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM RTT0Status
getTLS13RTT0Status
        if RTT0Status
st forall a. Eq a => a -> a -> Bool
== RTT0Status
RTT0Sent then
            case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extensionID_EarlyData [ExtensionRaw]
eexts of
              Just ByteString
_  -> 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
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[ExtensionRaw]
eexts)
              Maybe ByteString
Nothing -> 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
                  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
          else
            forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
    expectEncryptedExtensions Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"encrypted extensions")

    expectCertRequest :: Handshake13 -> RecvHandshake13M m ()
expectCertRequest (CertRequest13 ByteString
token [ExtensionRaw]
exts) = do
        forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
token [ExtensionRaw]
exts
        forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify

    expectCertRequest Handshake13
other = do
        forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ do
            Maybe ByteString -> HandshakeM ()
setCertReqToken   forall a. Maybe a
Nothing
            Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata  forall a. Maybe a
Nothing
            -- setCertReqSigAlgsCert Nothing
        forall {m :: * -> *}.
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify Handshake13
other

    expectCertAndVerify :: Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify (Certificate13 ByteString
_ CertificateChain
cc [[ExtensionRaw]]
_) = do
        RecvState IO
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx (CertificateChain -> Handshake
Certificates CertificateChain
cc)
        let pubkey :: PubKey
pubkey = Certificate -> PubKey
certPubKey forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate forall a b. (a -> b) -> a -> b
$ CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
cc
        Version
ver <- 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 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
        forall (m :: * -> *) a.
MonadIO m =>
Context
-> (ByteString -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
MonadIO m =>
PubKey -> ByteString -> Handshake13 -> m ()
expectCertVerify PubKey
pubkey
    expectCertAndVerify Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"server certificate")

    expectCertVerify :: PubKey -> ByteString -> Handshake13 -> m ()
expectCertVerify PubKey
pubkey ByteString
hChSc (CertVerify13 HashAndSignatureAlgorithm
sigAlg ByteString
sig) = do
        Bool
ok <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> ByteString
-> m Bool
checkCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
sigAlg ByteString
sig ByteString
hChSc
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError String
"cannot verify CertificateVerify"
    expectCertVerify PubKey
_ ByteString
_ Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"certificate verify")

    expectFinished :: ServerTrafficSecret a -> ByteString -> Handshake13 -> m ()
expectFinished (ServerTrafficSecret ByteString
baseKey) ByteString
hashValue (Finished13 ByteString
verifyData) =
        forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> ByteString -> ByteString -> m ()
checkFinished Context
ctx Hash
usedHash ByteString
baseKey ByteString
hashValue ByteString
verifyData
    expectFinished ServerTrafficSecret a
_ ByteString
_ Handshake13
p = forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (forall a. Show a => a -> String
show Handshake13
p) (forall a. a -> Maybe a
Just String
"server finished")

    setResumptionSecret :: BaseSecret ApplicationSecret -> IO ()
setResumptionSecret BaseSecret ApplicationSecret
applicationSecret = do
        BaseSecret ResumptionSecret
resumptionSecret <- Context
-> CipherChoice
-> BaseSecret ApplicationSecret
-> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret Context
ctx CipherChoice
choice BaseSecret ApplicationSecret
applicationSecret
        forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ BaseSecret ResumptionSecret -> HandshakeM ()
setTLS13ResumptionSecret BaseSecret ResumptionSecret
resumptionSecret

processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()
processCertRequest13 :: forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
token [ExtensionRaw]
exts = do
    let hsextID :: ExtensionID
hsextID = ExtensionID
extensionID_SignatureAlgorithms
        -- caextID = extensionID_SignatureAlgorithmsCert
    [DistinguishedName]
dNames <- m [DistinguishedName]
canames
    -- The @signature_algorithms@ extension is mandatory.
    Maybe [HashAndSignatureAlgorithm]
hsAlgs <- forall {m :: * -> *} {t} {a}.
(Extension t, MonadIO m) =>
ExtensionID -> (t -> Maybe a) -> m (Maybe a)
extalgs ExtensionID
hsextID SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm]
unsighash
    [CertificateType]
cTypes <- case Maybe [HashAndSignatureAlgorithm]
hsAlgs of
        Just [HashAndSignatureAlgorithm]
as ->
            let validAs :: [HashAndSignatureAlgorithm]
validAs = forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 [HashAndSignatureAlgorithm]
as
             in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
validAs
        Maybe [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
"invalid certificate request"
                        , Bool
True
                        , AlertDescription
HandshakeFailure )
    -- Unused:
    -- caAlgs <- extalgs caextID uncertsig
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx forall a b. (a -> b) -> a -> b
$ do
        Maybe ByteString -> HandshakeM ()
setCertReqToken  forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ByteString
token
        Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
hsAlgs, [DistinguishedName]
dNames)
        -- setCertReqSigAlgsCert caAlgs
  where
    canames :: m [DistinguishedName]
canames = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup
                   ExtensionID
extensionID_CertificateAuthorities [ExtensionRaw]
exts of
        Maybe ByteString
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just  ByteString
ext -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest ByteString
ext of
                         Just (CertificateAuthorities [DistinguishedName]
names) -> forall (m :: * -> *) a. Monad m => a -> m a
return [DistinguishedName]
names
                         Maybe CertificateAuthorities
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
                                  ( String
"invalid certificate request"
                                  , Bool
True
                                  , AlertDescription
HandshakeFailure )
    extalgs :: ExtensionID -> (t -> Maybe a) -> m (Maybe a)
extalgs ExtensionID
extID t -> Maybe a
decons = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
extID [ExtensionRaw]
exts of
        Maybe ByteString
Nothing   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just  ByteString
ext -> case forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest ByteString
ext of
                         Just t
e
                           -> forall (m :: * -> *) a. Monad m => a -> m a
return    forall a b. (a -> b) -> a -> b
$ t -> Maybe a
decons t
e
                         Maybe t
_ -> forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
                                  ( String
"invalid certificate request"
                                  , Bool
True
                                  , AlertDescription
HandshakeFailure )
    unsighash :: SignatureAlgorithms
              -> Maybe [HashAndSignatureAlgorithm]
    unsighash :: SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm]
unsighash (SignatureAlgorithms [HashAndSignatureAlgorithm]
a) = forall a. a -> Maybe a
Just [HashAndSignatureAlgorithm]
a
    {- Unused for now
    uncertsig :: SignatureAlgorithmsCert
              -> Maybe [HashAndSignatureAlgorithm]
    uncertsig (SignatureAlgorithmsCert a) = Just a
    -}

sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 :: forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (ClientTrafficSecret ByteString
baseKey) = do
    Maybe CertificateChain
chain <- ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx
    forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx forall a b. (a -> b) -> a -> b
$ do
        case Maybe CertificateChain
chain of
            Maybe CertificateChain
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just CertificateChain
cc -> forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe ByteString)
getCertReqToken forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}.
Monoid b =>
CertificateChain -> Maybe ByteString -> PacketFlightM b ()
sendClientData13 CertificateChain
cc
        Handshake13
rawFinished <- forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> m Handshake13
makeFinished Context
ctx Hash
usedHash ByteString
baseKey
        forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
rawFinished]
  where
    sendClientData13 :: CertificateChain -> Maybe ByteString -> PacketFlightM b ()
sendClientData13 CertificateChain
chain (Just ByteString
token) = do
        let (CertificateChain [SignedExact Certificate]
certs) = CertificateChain
chain
            certExts :: [[a]]
certExts = forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
certs) []
            cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = 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
        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
token CertificateChain
chain forall {a}. [[a]]
certExts]
        case [SignedExact Certificate]
certs of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [SignedExact Certificate]
_  -> do
                  ByteString
hChSc      <- forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
                  PubKey
pubKey     <- forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
                  HashAndSignatureAlgorithm
sigAlg     <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
signatureCompatible13 [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey
                  Handshake13
vfy        <- forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubKey HashAndSignatureAlgorithm
sigAlg ByteString
hChSc
                  forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
vfy]
    --
    sendClientData13 CertificateChain
_ Maybe ByteString
_ =
        forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
            ( String
"missing TLS 1.3 certificate request context token"
            , Bool
True
            , AlertDescription
InternalError
            )

setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
msgt [ExtensionRaw]
exts = 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
msgt of
    Just (ApplicationLayerProtocolNegotiation [ByteString
proto]) -> forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx forall a b. (a -> b) -> a -> b
$ do
        Maybe [ByteString]
mprotos <- TLSSt (Maybe [ByteString])
getClientALPNSuggest
        case Maybe [ByteString]
mprotos of
            Just [ByteString]
protos -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
proto forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
protos) forall a b. (a -> b) -> a -> b
$ do
                Bool -> TLSSt ()
setExtensionALPN Bool
True
                ByteString -> TLSSt ()
setNegotiatedProtocol ByteString
proto
            Maybe [ByteString]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ApplicationLayerProtocolNegotiation
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith ClientParams
cparams Context
ctx h :: Handshake13
h@(CertRequest13 ByteString
certReqCtx [ExtensionRaw]
exts) =
    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 ()
processHandshake13 Context
ctx Handshake13
h
        forall (m :: * -> *).
MonadIO m =>
Context -> ByteString -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx ByteString
certReqCtx [ExtensionRaw]
exts
        (Hash
usedHash, Cipher
_, CryptLevel
level, ByteString
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, ByteString)
getTxState 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
"unexpected post-handshake authentication request", Bool
True, AlertDescription
UnexpectedMessage)
        forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (forall a. ByteString -> ClientTrafficSecret a
ClientTrafficSecret ByteString
applicationSecretN)

postHandshakeAuthClientWith ClientParams
_ 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 postHandshakeAuthClientWith", Bool
True, AlertDescription
UnexpectedMessage)

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