{-# 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
_            = TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected handshake message received in 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 (SessionID, SessionData)
clientWantSessionResume ClientParams
cparams of
              Maybe (SessionID, SessionData)
Nothing         -> [Group]
groupsSupported
              Just (SessionID
_, SessionData
sdata) -> case SessionData -> Maybe Group
sessionGroup SessionData
sdata of
                  Maybe Group
Nothing  -> [] -- TLS 1.2 or earlier
                  Just Group
grp -> Group
grp Group -> [Group] -> [Group]
forall a. a -> [a] -> [a]
: (Group -> Bool) -> [Group] -> [Group]
forall a. (a -> Bool) -> [a] -> [a]
filter (Group -> Group -> Bool
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 Maybe (ClientRandom, Session, Version)
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 <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
-> ((ClientRandom, Session, Version) -> Bool)
-> Maybe (ClientRandom, Session, Version)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(ClientRandom
_, Session
_, Version
v) -> Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ver) Maybe (ClientRandom, Session, Version)
mparams) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"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 <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    if Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
TLS13 then
        if Bool
hrr then case Int -> [Group] -> [Group]
forall a. Int -> [a] -> [a]
drop Int
1 [Group]
groups of
            []      -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"group is exhausted in the client side", Bool
True, AlertDescription
IllegalParameter)
            [Group]
groups' -> do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (ClientRandom, Session, Version) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ClientRandom, Session, Version)
mparams) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server sent too many hello retries", Bool
True, AlertDescription
UnexpectedMessage)
                Maybe KeyShare
mks <- Context -> TLSSt (Maybe KeyShare) -> IO (Maybe KeyShare)
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 Group -> [Group] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups' -> do
                          Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
HelloRetryRequest
                          Context -> IO ()
clearTxState Context
ctx
                          let cparams' :: ClientParams
cparams' = ClientParams
cparams { clientEarlyData :: Maybe SessionID
clientEarlyData = Maybe SessionID
forall a. Maybe a
Nothing }
                          Context -> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall b. Monoid b => PacketFlightM b ()) -> IO ())
-> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> PacketFlightM 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] ((ClientRandom, Session, Version)
-> Maybe (ClientRandom, Session, Version)
forall a. a -> Maybe a
Just (ClientRandom
crand, Session
clientSession, Version
ver))
                    | Bool
otherwise -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server-selected group is not supported", Bool
True, AlertDescription
IllegalParameter)
                  Just KeyShare
_  -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"handshakeClient': invalid KeyShare value"
                  Maybe KeyShare
Nothing -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtt0 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server denied TLS 1.3 when connecting with early data", Bool
True, AlertDescription
HandshakeFailure)
        Bool
sessionResuming <- Context -> TLSSt Bool -> IO Bool
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 (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        compressions :: [Compression]
compressions = Supported -> [Compression]
supportedCompressions (Supported -> [Compression]) -> Supported -> [Compression]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        highestVer :: Version
highestVer = [Version] -> Version
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Version] -> Version) -> [Version] -> Version
forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        tls13 :: Bool
tls13 = Version
highestVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13
        ems :: EMSMode
ems = Supported -> EMSMode
supportedExtendedMasterSec (Supported -> EMSMode) -> Supported -> EMSMode
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        groupToSend :: Maybe Group
groupToSend = [Group] -> Maybe Group
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 (SessionID, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (SessionID, b, CipherChoice, Word32)
pskInfo Bool
rtt0 = [IO (Maybe ExtensionRaw)] -> IO [Maybe ExtensionRaw]
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
            , Bool -> IO (Maybe ExtensionRaw)
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
            , Maybe (SessionID, b, CipherChoice, Word32)
-> IO (Maybe ExtensionRaw)
forall (m :: * -> *) b.
Monad m =>
Maybe (SessionID, b, CipherChoice, Word32)
-> m (Maybe ExtensionRaw)
preSharedKeyExtension Maybe (SessionID, b, CipherChoice, Word32)
pskInfo -- MUST be last (RFC 8446)
            ]

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

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

        groupExtension :: IO (Maybe ExtensionRaw)
groupExtension = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExtensionRaw -> IO (Maybe ExtensionRaw))
-> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a b. (a -> b) -> a -> b
$ ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ NegotiatedGroups -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (NegotiatedGroups -> ExtensionRaw)
-> NegotiatedGroups -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [Group] -> NegotiatedGroups
NegotiatedGroups (Supported -> [Group]
supportedGroups (Supported -> [Group]) -> Supported -> [Group]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx)
        ecPointExtension :: IO (Maybe ExtensionRaw)
ecPointExtension = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExtensionRaw -> IO (Maybe ExtensionRaw))
-> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a b. (a -> b) -> a -> b
$ ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ EcPointFormatsSupported -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EcPointFormatsSupported -> ExtensionRaw)
-> EcPointFormatsSupported -> ExtensionRaw
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 = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExtensionRaw -> IO (Maybe ExtensionRaw))
-> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a b. (a -> b) -> a -> b
$ ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ SignatureAlgorithms -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (SignatureAlgorithms -> ExtensionRaw)
-> SignatureAlgorithms -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [HashAndSignatureAlgorithm] -> SignatureAlgorithms
SignatureAlgorithms ([HashAndSignatureAlgorithm] -> SignatureAlgorithms)
-> [HashAndSignatureAlgorithm] -> SignatureAlgorithms
forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams

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

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

        sessionAndCipherToResume13 :: Maybe (SessionID, SessionData, Cipher)
sessionAndCipherToResume13 = do
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
tls13
            (SessionID
sid, SessionData
sdata) <- ClientParams -> Maybe (SessionID, SessionData)
clientWantSessionResume ClientParams
cparams
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SessionData -> Version
sessionVersion SessionData
sdata Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13)
            Cipher
sCipher <- (Cipher -> Bool) -> [Cipher] -> Maybe Cipher
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Cipher
c -> Cipher -> ExtensionID
cipherID Cipher
c ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== SessionData -> ExtensionID
sessionCipher SessionData
sdata) [Cipher]
ciphers
            (SessionID, SessionData, Cipher)
-> Maybe (SessionID, SessionData, Cipher)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionID
sid, SessionData
sdata, Cipher
sCipher)

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

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

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

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

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

        postHandshakeAuthExtension :: IO (Maybe ExtensionRaw)
postHandshakeAuthExtension
          | Context -> Bool
ctxQUICMode Context
ctx = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExtensionRaw
forall a. Maybe a
Nothing
          | Bool
tls13           = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExtensionRaw -> IO (Maybe ExtensionRaw))
-> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a b. (a -> b) -> a -> b
$ ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ PostHandshakeAuth -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw PostHandshakeAuth
PostHandshakeAuth
          | Bool
otherwise       = Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExtensionRaw
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 -> [ExtensionRaw] -> IO [ExtensionRaw]
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionRaw]
exts
                Just (a
_, SessionData
sdata, CipherChoice
choice, d
_) -> do
                      let psk :: SessionID
psk = SessionData -> SessionID
sessionSecret SessionData
sdata
                          earlySecret :: BaseSecret EarlySecret
earlySecret = CipherChoice -> Maybe SessionID -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice (SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
psk)
                      Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ BaseSecret EarlySecret -> HandshakeM ()
setTLS13EarlySecret BaseSecret EarlySecret
earlySecret
                      let ech :: SessionID
ech = Handshake -> SessionID
encodeHandshake Handshake
ch
                          h :: Hash
h = CipherChoice -> Hash
cHash CipherChoice
choice
                          siz :: Int
siz = Hash -> Int
hashDigestSize Hash
h
                      SessionID
binder <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe SessionID
-> IO SessionID
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
h (Int
siz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
ech)
                      let exts' :: [ExtensionRaw]
exts' = [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a]
init [ExtensionRaw]
exts [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw -> ExtensionRaw
adjust ([ExtensionRaw] -> ExtensionRaw
forall a. [a] -> a
last [ExtensionRaw]
exts)]
                          adjust :: ExtensionRaw -> ExtensionRaw
adjust (ExtensionRaw ExtensionID
eid SessionID
withoutBinders) = ExtensionID -> SessionID -> ExtensionRaw
ExtensionRaw ExtensionID
eid SessionID
withBinders
                            where
                              withBinders :: SessionID
withBinders = SessionID -> SessionID -> SessionID
replacePSKBinder SessionID
withoutBinders SessionID
binder
                      [ExtensionRaw] -> IO [ExtensionRaw]
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
_) -> (ClientRandom, Session) -> IO (ClientRandom, Session)
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 (SessionID, SessionData)
clientWantSessionResume ClientParams
cparams of
                            Maybe (SessionID, SessionData)
Nothing -> Maybe SessionID -> Session
Session Maybe SessionID
forall a. Maybe a
Nothing
                            Just (SessionID
sid, SessionData
sdata)
                                | SessionData -> Version
sessionVersion SessionData
sdata Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS13     -> Maybe SessionID -> Session
Session Maybe SessionID
forall a. Maybe a
Nothing
                                | EMSMode
ems EMSMode -> EMSMode -> Bool
forall a. Eq a => a -> a -> Bool
== EMSMode
RequireEMS Bool -> Bool -> Bool
&& Bool
noSessionEMS -> Maybe SessionID -> Session
Session Maybe SessionID
forall a. Maybe a
Nothing
                                | Bool
otherwise                         -> Maybe SessionID -> Session
Session (SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
sid)
                              where noSessionEMS :: Bool
noSessionEMS = SessionFlag
SessionEMS SessionFlag -> [SessionFlag] -> Bool
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 Session -> Session -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe SessionID -> Session
Session Maybe SessionID
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
                            (ClientRandom, Session) -> IO (ClientRandom, Session)
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientRandom
crand, Session
randomSession)
                        else (ClientRandom, Session) -> IO (ClientRandom, Session)
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 <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Version -> ClientRandom -> IO ()
startHandshake Context
ctx Version
ver ClientRandom
crand
            Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersionIfUnset Version
highestVer
            let cipherIds :: [ExtensionID]
cipherIds = (Cipher -> ExtensionID) -> [Cipher] -> [ExtensionID]
forall a b. (a -> b) -> [a] -> [b]
map Cipher -> ExtensionID
cipherID [Cipher]
ciphers
                compIds :: [CompressionID]
compIds = (Compression -> CompressionID) -> [Compression] -> [CompressionID]
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 SessionID
-> Handshake
ClientHello Version
ver ClientRandom
crand Session
clientSession [ExtensionID]
cipherIds [CompressionID]
compIds [ExtensionRaw]
exts Maybe SessionID
forall a. Maybe a
Nothing
            Maybe (SessionID, SessionData, CipherChoice, Word32)
pskInfo <- IO (Maybe (SessionID, SessionData, CipherChoice, Word32))
getPskInfo
            let rtt0info :: Maybe (CipherChoice, SessionID)
rtt0info = Maybe (SessionID, SessionData, CipherChoice, Word32)
pskInfo Maybe (SessionID, SessionData, CipherChoice, Word32)
-> ((SessionID, SessionData, CipherChoice, Word32)
    -> Maybe (CipherChoice, SessionID))
-> Maybe (CipherChoice, SessionID)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SessionID, SessionData, CipherChoice, Word32)
-> Maybe (CipherChoice, SessionID)
forall a a d. (a, SessionData, a, d) -> Maybe (a, SessionID)
get0RTTinfo
                rtt0 :: Bool
rtt0 = Maybe (CipherChoice, SessionID) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (CipherChoice, SessionID)
rtt0info
            [ExtensionRaw]
extensions0 <- [Maybe ExtensionRaw] -> [ExtensionRaw]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe ExtensionRaw] -> [ExtensionRaw])
-> IO [Maybe ExtensionRaw] -> IO [ExtensionRaw]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (SessionID, SessionData, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
forall b.
Maybe (SessionID, b, CipherChoice, Word32)
-> Bool -> IO [Maybe ExtensionRaw]
getExtensions Maybe (SessionID, SessionData, CipherChoice, Word32)
pskInfo Bool
rtt0
            let extensions1 :: [ExtensionRaw]
extensions1 = Shared -> [ExtensionRaw]
sharedHelloExtensions (ClientParams -> Shared
clientShared ClientParams
cparams) [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
extensions0
            [ExtensionRaw]
extensions <- Maybe (SessionID, SessionData, CipherChoice, Word32)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
forall a d.
Maybe (a, SessionData, CipherChoice, d)
-> [ExtensionRaw] -> Handshake -> IO [ExtensionRaw]
adjustExtentions Maybe (SessionID, SessionData, CipherChoice, Word32)
pskInfo [ExtensionRaw]
extensions1 (Handshake -> IO [ExtensionRaw]) -> Handshake -> IO [ExtensionRaw]
forall a b. (a -> b) -> a -> b
$ [ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions1
            Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [[ExtensionRaw] -> Handshake
mkClientHello [ExtensionRaw]
extensions]
            Maybe EarlySecretInfo
mEarlySecInfo <- case Maybe (CipherChoice, SessionID)
rtt0info of
               Maybe (CipherChoice, SessionID)
Nothing   -> Maybe EarlySecretInfo -> IO (Maybe EarlySecretInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe EarlySecretInfo
forall a. Maybe a
Nothing
               Just (CipherChoice, SessionID)
info -> EarlySecretInfo -> Maybe EarlySecretInfo
forall a. a -> Maybe a
Just (EarlySecretInfo -> Maybe EarlySecretInfo)
-> IO EarlySecretInfo -> IO (Maybe EarlySecretInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CipherChoice, SessionID) -> IO EarlySecretInfo
send0RTT (CipherChoice, SessionID)
info
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hrr (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> ClientState -> IO ()
contextSync Context
ctx (ClientState -> IO ()) -> ClientState -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe EarlySecretInfo -> ClientState
SendClientHello Maybe EarlySecretInfo
mEarlySecInfo
            (Bool, [ExtensionID]) -> IO (Bool, [ExtensionID])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
rtt0, (ExtensionRaw -> ExtensionID) -> [ExtensionRaw] -> [ExtensionID]
forall a b. (a -> b) -> [a] -> [b]
map (\(ExtensionRaw ExtensionID
i SessionID
_) -> ExtensionID
i) [ExtensionRaw]
extensions)

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

        send0RTT :: (CipherChoice, SessionID) -> IO EarlySecretInfo
send0RTT (CipherChoice
choice, SessionID
earlyData) = do
                let usedCipher :: Cipher
usedCipher = CipherChoice -> Cipher
cCipher CipherChoice
choice
                    usedHash :: Hash
usedHash = CipherChoice -> Hash
cHash CipherChoice
choice
                Just BaseSecret EarlySecret
earlySecret <- Context
-> HandshakeM (Maybe (BaseSecret EarlySecret))
-> IO (Maybe (BaseSecret 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 SessionID (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (BaseSecret EarlySecret -> Either SessionID (BaseSecret EarlySecret)
forall a b. b -> Either a b
Right BaseSecret EarlySecret
earlySecret) Bool
False
                let clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Context -> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall b. Monoid b => PacketFlightM b ()) -> IO ())
-> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> PacketFlightM b ()
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
                    Context
-> Hash -> Cipher -> ClientTrafficSecret EarlySecret -> IO ()
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
                    Maybe Int -> (SessionID -> IO ()) -> SessionID -> IO ()
forall (m :: * -> *) a.
Monad m =>
Maybe Int -> (SessionID -> m a) -> SessionID -> m ()
mapChunks_ Maybe Int
len (Context -> Packet13 -> IO ()
sendPacket13 Context
ctx (Packet13 -> IO ())
-> (SessionID -> Packet13) -> SessionID -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SessionID -> Packet13
AppData13) SessionID
earlyData
                -- We set RTT0Sent even in quicMode
                Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Sent
                EarlySecretInfo -> IO EarlySecretInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (EarlySecretInfo -> IO EarlySecretInfo)
-> EarlySecretInfo -> IO EarlySecretInfo
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 = (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext ((Packet -> IO (RecvState IO)) -> RecvState IO)
-> (Packet -> IO (RecvState IO)) -> RecvState IO
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 ((Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake ((Handshake -> IO (RecvState IO)) -> RecvState IO)
-> (Handshake -> IO (RecvState IO)) -> RecvState IO
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 RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
recvState
                                        else [(AlertLevel, AlertDescription)] -> IO (RecvState IO)
forall (m :: * -> *) a a. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
                                [(AlertLevel, AlertDescription)]
_ -> [(AlertLevel, AlertDescription)] -> IO (RecvState IO)
forall (m :: * -> *) a a. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
                        Packet
_ -> String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet -> String
forall a. Show a => a -> String
show Packet
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"handshake")
                throwAlert :: a -> m a
throwAlert a
a = TLSError -> m a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m a) -> TLSError -> m a
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"expecting server hello, got alert : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
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 <- Context -> CertificateChain -> PrivKey -> IO PubKey
forall (m :: * -> *).
MonadIO m =>
Context -> CertificateChain -> PrivKey -> m PubKey
storePrivInfo Context
ctx CertificateChain
cc PrivKey
privkey
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey -> [CertificateType] -> Bool
certificateCompatible PubKey
pubkey [CertificateType]
cTypes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
            ( PubKey -> String
pubkeyType PubKey
pubkey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" credential does not match allowed certificate types"
            , Bool
True
            , AlertDescription
InternalError )
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
pubkey PubKey -> Version -> Bool
`versionCompatible` Version
ver) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
            ( PubKey -> String
pubkeyType PubKey
pubkey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" credential is not supported at version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
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 =
    Context
-> HandshakeM (Maybe CertReqCBdata) -> IO (Maybe CertReqCBdata)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe CertReqCBdata)
getCertReqCBdata IO (Maybe CertReqCBdata)
-> (Maybe CertReqCBdata -> IO (Maybe CertificateChain))
-> IO (Maybe CertificateChain)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe CertReqCBdata
Nothing     -> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe CertificateChain
forall a. Maybe a
Nothing
        Just CertReqCBdata
cbdata -> do
            let callback :: OnCertificateRequest
callback = ClientHooks -> OnCertificateRequest
onCertificateRequest (ClientHooks -> OnCertificateRequest)
-> ClientHooks -> OnCertificateRequest
forall a b. (a -> b) -> a -> b
$ ClientParams -> ClientHooks
clientHooks ClientParams
cparams
            Maybe Credential
chain <- IO (Maybe Credential) -> IO (Maybe Credential)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Credential) -> IO (Maybe Credential))
-> IO (Maybe Credential) -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ OnCertificateRequest
callback CertReqCBdata
cbdata IO (Maybe Credential)
-> (SomeException -> IO (Maybe Credential))
-> IO (Maybe Credential)
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
                String -> SomeException -> IO (Maybe Credential)
forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"certificate request callback failed"
            case Maybe Credential
chain of
                Maybe Credential
Nothing
                    -> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just (CertificateChain -> Maybe CertificateChain)
-> CertificateChain -> Maybe CertificateChain
forall a b. (a -> b) -> a -> b
$ [SignedExact Certificate] -> CertificateChain
CertificateChain []
                Just (CertificateChain [], PrivKey
_)
                    -> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
forall a. a -> Maybe a
Just (CertificateChain -> Maybe CertificateChain)
-> CertificateChain -> Maybe CertificateChain
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
                       Maybe CertificateChain -> IO (Maybe CertificateChain)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CertificateChain -> IO (Maybe CertificateChain))
-> Maybe CertificateChain -> IO (Maybe CertificateChain)
forall a b. (a -> b) -> a -> b
$ CertificateChain -> Maybe CertificateChain
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]
_)) <- Context
-> HandshakeM (Maybe CertReqCBdata) -> IO (Maybe CertReqCBdata)
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
(&&) (Bool -> Bool -> Bool)
-> (HashAndSignatureAlgorithm -> Bool)
-> HashAndSignatureAlgorithm
-> Bool
-> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PubKey -> HashAndSignatureAlgorithm -> Bool
isCompatible PubKey
pubKey
                    (HashAndSignatureAlgorithm -> Bool -> Bool)
-> (HashAndSignatureAlgorithm -> Bool)
-> HashAndSignatureAlgorithm
-> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (HashAndSignatureAlgorithm -> [HashAndSignatureAlgorithm] -> Bool)
-> [HashAndSignatureAlgorithm] -> HashAndSignatureAlgorithm -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashAndSignatureAlgorithm -> [HashAndSignatureAlgorithm] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [HashAndSignatureAlgorithm]
hashSigs
    case (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> Maybe HashAndSignatureAlgorithm
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find HashAndSignatureAlgorithm -> Bool
want [HashAndSignatureAlgorithm]
cHashSigs of
        Just HashAndSignatureAlgorithm
best -> HashAndSignatureAlgorithm -> IO HashAndSignatureAlgorithm
forall (m :: * -> *) a. Monad m => a -> m a
return HashAndSignatureAlgorithm
best
        Maybe HashAndSignatureAlgorithm
Nothing   -> TLSError -> IO HashAndSignatureAlgorithm
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO HashAndSignatureAlgorithm)
-> TLSError -> IO HashAndSignatureAlgorithm
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
k String -> String -> String
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 =
    [CertificateType] -> [CertificateType]
forall a. Eq a => [a] -> [a]
nub ([CertificateType] -> [CertificateType])
-> [CertificateType] -> [CertificateType]
forall a b. (a -> b) -> a -> b
$ (HashAndSignatureAlgorithm
 -> [CertificateType] -> [CertificateType])
-> [CertificateType]
-> [HashAndSignatureAlgorithm]
-> [CertificateType]
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 CertificateType -> CertificateType -> Bool
forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType
                 -> CertificateType
cType CertificateType -> [CertificateType] -> [CertificateType]
forall a. a -> [a] -> [a]
: [CertificateType]
acc
       Maybe CertificateType
_         -> [CertificateType]
acc
--
clientSupportedCtypes :: Context
                      -> [CertificateType]
clientSupportedCtypes :: Context -> [CertificateType]
clientSupportedCtypes Context
ctx =
    [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes ([HashAndSignatureAlgorithm] -> [CertificateType])
-> [HashAndSignatureAlgorithm] -> [CertificateType]
forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
--
sigAlgsToCertTypes :: Context
                   -> [HashAndSignatureAlgorithm]
                   -> [CertificateType]
sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
hashSigs =
    (CertificateType -> Bool) -> [CertificateType] -> [CertificateType]
forall a. (a -> Bool) -> [a] -> [a]
filter (CertificateType -> [CertificateType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [HashAndSignatureAlgorithm] -> [CertificateType]
supportedCtypes [HashAndSignatureAlgorithm]
hashSigs) ([CertificateType] -> [CertificateType])
-> [CertificateType] -> [CertificateType]
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 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendClientKeyXchg IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
sendCertificateVerify
  where
        sendCertificate :: IO ()
sendCertificate = do
            Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setClientCertSent Bool
False
            ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx IO (Maybe CertificateChain)
-> (Maybe CertificateChain -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe CertificateChain
Nothing                    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just cc :: CertificateChain
cc@(CertificateChain [SignedExact Certificate]
certs) -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SignedExact Certificate] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
certs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setClientCertSent Bool
True
                    Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [CertificateChain -> Handshake
Certificates CertificateChain
cc]

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

                    let premaster :: SessionID
premaster = Version -> SessionID -> SessionID
encodePreMasterSecret Version
clientVersion SessionID
prerand
                        setMasterSec :: HandshakeM SessionID
setMasterSec = Version -> Role -> SessionID -> HandshakeM SessionID
forall preMaster.
ByteArrayAccess preMaster =>
Version -> Role -> preMaster -> HandshakeM SessionID
setMasterSecretFromPre Version
xver Role
ClientRole SessionID
premaster
                    SessionID
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.
                        SessionID
e <- Context -> SessionID -> IO SessionID
encryptRSA Context
ctx SessionID
premaster
                        let extra :: SessionID
extra = if Version
xver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
TLS10
                                        then SessionID
B.empty
                                        else ExtensionID -> SessionID
encodeWord16 (ExtensionID -> SessionID) -> ExtensionID -> SessionID
forall a b. (a -> b) -> a -> b
$ Int -> ExtensionID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> ExtensionID) -> Int -> ExtensionID
forall a b. (a -> b) -> a -> b
$ SessionID -> Int
B.length SessionID
e
                        SessionID -> IO SessionID
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionID -> IO SessionID) -> SessionID -> IO SessionID
forall a b. (a -> b) -> a -> b
$ SessionID
extra SessionID -> SessionID -> SessionID
`B.append` SessionID
e
                    (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
-> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
forall (m :: * -> *) a. Monad m => a -> m a
return (SessionID -> ClientKeyXchgAlgorithmData
CKX_RSA SessionID
encryptedPreMaster, HandshakeM SessionID
setMasterSec)
                CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
getCKX_DHE
                CipherKeyExchangeType
CipherKeyExchange_DHE_DSS -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
getCKX_DHE
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
getCKX_ECDHE
                CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
getCKX_ECDHE
                CipherKeyExchangeType
_ -> TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID))
-> TLSError
-> IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
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 (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [ClientKeyXchgAlgorithmData -> Handshake
ClientKeyXchg ClientKeyXchgAlgorithmData
ckx]
            SessionID
masterSecret <- Context -> HandshakeM SessionID -> IO SessionID
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM SessionID
setMasterSec
            Context -> MasterSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (SessionID -> MasterSecret
MasterSecret SessionID
masterSecret)
          where getCKX_DHE :: IO (ClientKeyXchgAlgorithmData, HandshakeM SessionID)
getCKX_DHE = do
                    Version
xver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
                    ServerDHParams
serverParams <- Context -> HandshakeM ServerDHParams -> IO ServerDHParams
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

                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Group -> Bool) -> Maybe Group -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Context -> Group -> Bool
isSupportedGroup Context
ctx) Maybe Group
ffGroup) (IO () -> IO ()) -> IO () -> IO ()
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 IO GroupUsage -> (SomeException -> IO GroupUsage) -> IO GroupUsage
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException`
                                          String -> SomeException -> IO GroupUsage
forall a. String -> SomeException -> IO a
throwMiscErrorOnException String
"custom group callback failed"
                        case GroupUsage
groupUsage of
                            GroupUsage
GroupUsageInsecure           -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"FFDHE group is not secure enough", Bool
True, AlertDescription
InsufficientSecurity)
                            GroupUsageUnsupported String
reason -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unsupported FFDHE group: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason, Bool
True, AlertDescription
HandshakeFailure)
                            GroupUsage
GroupUsageInvalidPublic      -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server public key", Bool
True, AlertDescription
IllegalParameter)
                            GroupUsage
GroupUsageValid              -> () -> IO ()
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
                                 (DHPublic, DHKey) -> IO (DHPublic, DHKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic
clientDHPub, DHKey
premaster)
                             Just Group
grp -> do
                                 Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup Group
grp
                                 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   -> TLSError -> IO (DHPublic, DHKey)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (DHPublic, DHKey))
-> TLSError -> IO (DHPublic, DHKey)
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"invalid server " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Group -> String
forall a. Show a => a -> String
show Group
grp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" public key", Bool
True, AlertDescription
IllegalParameter)
                                     Just (DHPublic, DHKey)
pair -> (DHPublic, DHKey) -> IO (DHPublic, DHKey)
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic, DHKey)
pair

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

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

                -- Fetch all handshake messages up to now.
                SessionID
msgs   <- Context -> HandshakeM SessionID -> IO SessionID
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM SessionID -> IO SessionID)
-> HandshakeM SessionID -> IO SessionID
forall a b. (a -> b) -> a -> b
$ [SessionID] -> SessionID
B.concat ([SessionID] -> SessionID)
-> HandshakeM [SessionID] -> HandshakeM SessionID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeM [SessionID]
getHandshakeMessages
                DigitallySigned
sigDig <- Context
-> Version
-> PubKey
-> Maybe HashAndSignatureAlgorithm
-> SessionID
-> IO DigitallySigned
createCertificateVerify Context
ctx Version
ver PubKey
pubKey Maybe HashAndSignatureAlgorithm
mhashSig SessionID
msgs
                Context -> Packet -> IO ()
sendPacket Context
ctx (Packet -> IO ()) -> Packet -> IO ()
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 SessionID
content)
  | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SecureRenegotiation = do
        SessionID
cv <- Role -> TLSSt SessionID
getVerifiedData Role
ClientRole
        SessionID
sv <- Role -> TLSSt SessionID
getVerifiedData Role
ServerRole
        let bs :: SessionID
bs = SecureRenegotiation -> SessionID
forall a. Extension a => a -> SessionID
extensionEncode (SessionID -> Maybe SessionID -> SecureRenegotiation
SecureRenegotiation SessionID
cv (Maybe SessionID -> SecureRenegotiation)
-> Maybe SessionID -> SecureRenegotiation
forall a b. (a -> b) -> a -> b
$ SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
sv)
        Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SessionID
bs SessionID -> SessionID -> Bool
`bytesEq` SessionID
content) (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ TLSError -> TLSSt ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TLSError -> TLSSt ()) -> TLSError -> TLSSt ()
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 ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_SupportedVersions = case MessageType -> SessionID -> Maybe SupportedVersions
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
MsgTServerHello SessionID
content of
      Just (SupportedVersionsServerHello Version
ver) -> Version -> TLSSt ()
setVersion Version
ver
      Maybe SupportedVersions
_                                       -> () -> TLSSt ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
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 (Maybe KeyShare -> TLSSt ()) -> Maybe KeyShare -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ MessageType -> SessionID -> Maybe KeyShare
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
msgt SessionID
content
  | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_PreSharedKey =
        Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey (Maybe PreSharedKey -> TLSSt ()) -> Maybe PreSharedKey -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ MessageType -> SessionID -> Maybe PreSharedKey
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
MsgTServerHello SessionID
content
processServerExtension ExtensionRaw
_ = () -> TLSSt ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException String
msg SomeException
e =
    TLSError -> IO a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO a) -> TLSError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc (String -> TLSError) -> String -> TLSError
forall a b. (a -> b) -> a -> b
$ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
rver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
SSL2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"ssl2 is not supported", Bool
True, AlertDescription
ProtocolVersion)
    -- find the compression and cipher methods that the server want to use.
    Cipher
cipherAlg <- case (Cipher -> Bool) -> [Cipher] -> Maybe Cipher
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
(==) ExtensionID
cipher (ExtensionID -> Bool) -> (Cipher -> ExtensionID) -> Cipher -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> ExtensionID
cipherID) (Supported -> [Cipher]
supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
                     Maybe Cipher
Nothing  -> TLSError -> IO Cipher
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Cipher) -> TLSError -> IO Cipher
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 -> Cipher -> IO Cipher
forall (m :: * -> *) a. Monad m => a -> m a
return Cipher
alg
    Compression
compressAlg <- case (Compression -> Bool) -> [Compression] -> Maybe Compression
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
(==) CompressionID
compression (CompressionID -> Bool)
-> (Compression -> CompressionID) -> Compression -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compression -> CompressionID
compressionID) (Supported -> [Compression]
supportedCompressions (Supported -> [Compression]) -> Supported -> [Compression]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
                       Maybe Compression
Nothing  -> TLSError -> IO Compression
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Compression) -> TLSError -> IO Compression
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 -> Compression -> IO Compression
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 SessionID
_)
          | ExtensionID
i ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
extensionID_Cookie = Bool
False -- for HRR
          | Bool
otherwise               = ExtensionID
i ExtensionID -> [ExtensionID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
sentExts
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((ExtensionRaw -> Bool) -> [ExtensionRaw] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExtensionRaw -> Bool
checkExt [ExtensionRaw]
exts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"spurious extensions received", Bool
True, AlertDescription
UnsupportedExtension)

    let resumingSession :: Maybe SessionData
resumingSession =
            case ClientParams -> Maybe (SessionID, SessionData)
clientWantSessionResume ClientParams
cparams of
                Just (SessionID
sessionId, SessionData
sessionData) -> if Session
serverSession Session -> Session -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe SessionID -> Session
Session (SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
sessionId) then SessionData -> Maybe SessionData
forall a. a -> Maybe a
Just SessionData
sessionData else Maybe SessionData
forall a. Maybe a
Nothing
                Maybe (SessionID, SessionData)
Nothing                       -> Maybe SessionData
forall a. Maybe a
Nothing
        isHRR :: Bool
isHRR = ServerRandom -> Bool
isHelloRetryRequest ServerRandom
serverRan
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> TLSSt ()
setTLS13HRR Bool
isHRR
        Maybe Cookie -> TLSSt ()
setTLS13Cookie (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isHRR Maybe () -> Maybe SessionID -> Maybe SessionID
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExtensionID -> [ExtensionRaw] -> Maybe SessionID
extensionLookup ExtensionID
extensionID_Cookie [ExtensionRaw]
exts Maybe SessionID -> (SessionID -> Maybe Cookie) -> Maybe Cookie
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> SessionID -> Maybe Cookie
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
MsgTServerHello)
        Session -> Bool -> TLSSt ()
setSession Session
serverSession (Maybe SessionData -> Bool
forall a. Maybe a -> Bool
isJust Maybe SessionData
resumingSession)
        Version -> TLSSt ()
setVersion Version
rver -- must be before processing supportedVersions ext
        (ExtensionRaw -> TLSSt ()) -> [ExtensionRaw] -> TLSSt ()
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 <- Context -> TLSSt Version -> IO Version
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.
    --
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> [Version] -> ServerRandom -> Bool
isDowngraded Version
ver (Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams) ServerRandom
serverRan) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"version downgrade detected", Bool
True, AlertDescription
IllegalParameter)

    case (Version -> Bool) -> [Version] -> Maybe Version
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ver) (Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
        Maybe Version
Nothing -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
ver String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not supported", Bool
True, AlertDescription
ProtocolVersion)
        Just Version
_  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    if Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
TLS12 then do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Session
serverSession Session -> Session -> Bool
forall a. Eq a => a -> a -> Bool
/= Session
clientSession) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"received mismatched legacy session", Bool
True, AlertDescription
IllegalParameter)
        Established
established <- Context -> IO Established
ctxEstablished Context
ctx
        Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"renegotiation to TLS 1.3 or later is not allowed", Bool
True, AlertDescription
ProtocolVersion)
        CompressionID -> IO ()
forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
compression
        IO (Either TLSError ()) -> IO ()
forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError (IO (Either TLSError ()) -> IO ())
-> IO (Either TLSError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context
-> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM (Either TLSError ()) -> IO (Either TLSError ()))
-> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
forall a b. (a -> b) -> a -> b
$ Cipher -> HandshakeM (Either TLSError ())
setHelloParameters13 Cipher
cipherAlg
        RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState IO
forall (m :: * -> *). RecvState m
RecvStateDone
      else do
        Bool
ems <- Context -> Version -> MessageType -> [ExtensionRaw] -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMasterSec Context
ctx Version
ver MessageType
MsgTServerHello [ExtensionRaw]
exts
        Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> ServerRandom -> Cipher -> Compression -> HandshakeM ()
setServerHelloParameters Version
rver ServerRandom
serverRan Cipher
cipherAlg Compression
compressAlg
        case Maybe SessionData
resumingSession of
            Maybe SessionData
Nothing          -> RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate ClientParams
cparams Context
ctx)
            Just SessionData
sessionData -> do
                let emsSession :: Bool
emsSession = SessionFlag
SessionEMS SessionFlag -> [SessionFlag] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SessionData -> [SessionFlag]
sessionFlags SessionData
sessionData
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ems Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
emsSession) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    let err :: String
err = String
"server resumes a session which is not EMS consistent"
                     in TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
err, Bool
True, AlertDescription
HandshakeFailure)
                let masterSecret :: SessionID
masterSecret = SessionData -> SessionID
sessionSecret SessionData
sessionData
                Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> Role -> SessionID -> HandshakeM ()
setMasterSecret Version
rver Role
ClientRole SessionID
masterSecret
                Context -> MasterSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (SessionID -> MasterSecret
MasterSecret SessionID
masterSecret)
                RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStateNext Packet -> IO (RecvState IO)
expectChangeCipher
onServerHello Context
_ ClientParams
_ Session
_ [ExtensionID]
_ Handshake
p = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake -> String
forall a. Show a => a -> String
show Handshake
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CertificateChain -> Bool
isNullCertificateChain CertificateChain
certs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server certificate missing", Bool
True, AlertDescription
DecodeError)
    -- run certificate recv hook
    Context -> (Hooks -> IO ()) -> IO ()
forall a. Context -> (Hooks -> IO a) -> IO a
ctxWithHooks Context
ctx (Hooks -> CertificateChain -> IO ()
`hookRecvCertificates` CertificateChain
certs)
    -- then run certificate validation
    CertificateUsage
usage <- IO CertificateUsage
-> (SomeException -> IO CertificateUsage) -> IO CertificateUsage
forall a. IO a -> (SomeException -> IO a) -> IO a
catchException ([FailedReason] -> CertificateUsage
wrapCertificateChecks ([FailedReason] -> CertificateUsage)
-> IO [FailedReason] -> IO CertificateUsage
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 -> CertificateRejectReason -> IO ()
forall (m :: * -> *) a. MonadIO m => CertificateRejectReason -> m a
certificateRejected CertificateRejectReason
reason
    RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (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, SessionID)
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 <- Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
            case Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage Cipher
cipher of
                []    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [ExtKeyUsageFlag]
flags -> [ExtKeyUsageFlag] -> CertificateChain -> IO ()
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 = RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake Handshake -> IO (RecvState IO)
expectFinish
expectChangeCipher Packet
p                = String -> Maybe String -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Packet -> String
forall a. Show a => a -> String
show Packet
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"change cipher")

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

processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange Context
ctx (ServerKeyXchg ServerKeyXchgAlgorithmData
origSkx) = do
    Cipher
cipher <- Context -> HandshakeM Cipher -> IO 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
    RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (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 SessionID
bytes) -> do
                    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
                    case Version
-> CipherKeyExchangeType
-> SessionID
-> Either TLSError ServerKeyXchgAlgorithmData
decodeReallyServerKeyXchgAlgorithmData Version
ver CipherKeyExchangeType
cke SessionID
bytes of
                        Left TLSError
_        -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CipherKeyExchangeType -> String
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
_)           -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unknown server key exchange received, expecting: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CipherKeyExchangeType -> String
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" signature for dhparams " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ServerDHParams -> String
forall a. Show a => a -> String
show ServerDHParams
dhparams)
            Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
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
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
verified (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadIO m => String -> m a
decryptError (String
"bad " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PubKey -> String
pubkeyType PubKey
publicKey String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" signature for ecdhparams")
            Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
ecdhparams

        getSignaturePublicKey :: KeyExchangeSignatureAlg -> IO PubKey
getSignaturePublicKey KeyExchangeSignatureAlg
kxsAlg = do
            PubKey
publicKey <- Context -> HandshakeM PubKey -> IO PubKey
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM PubKey
getRemotePublicKey
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyExchangeSignatureAlg -> PubKey -> Bool
isKeyExchangeSignatureKey KeyExchangeSignatureAlg
kxsAlg PubKey
publicKey) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server public key algorithm is incompatible with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ KeyExchangeSignatureAlg -> String
forall a. Show a => a -> String
show KeyExchangeSignatureAlg
kxsAlg, Bool
True, AlertDescription
HandshakeFailure)
            Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PubKey
publicKey PubKey -> Version -> Bool
`versionCompatible` Version
ver) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (Version -> String
forall a. Show a => a -> String
show Version
ver String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no support for " String -> String -> String
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)
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Group -> Bool) -> PubKey -> Bool
satisfiesEcPredicate (Group -> [Group] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groups) PubKey
publicKey) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"server public key has unsupported elliptic curve", Bool
True, AlertDescription
IllegalParameter)
            PubKey -> IO PubKey
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 <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
TLS12 Bool -> Bool -> Bool
&& Maybe [HashAndSignatureAlgorithm] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [HashAndSignatureAlgorithm]
sigAlgs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol
            ( String
"missing TLS 1.2 certificate request signature algorithms"
            , Bool
True
            , AlertDescription
InternalError
            )
    let cTypes :: [CertificateType]
cTypes = (CertificateType -> Bool) -> [CertificateType] -> [CertificateType]
forall a. (a -> Bool) -> [a] -> [a]
filter (CertificateType -> CertificateType -> Bool
forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType) [CertificateType]
cTypesSent
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata (Maybe CertReqCBdata -> HandshakeM ())
-> Maybe CertReqCBdata -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ CertReqCBdata -> Maybe CertReqCBdata
forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
sigAlgs, [DistinguishedName]
dNames)
    RecvState IO -> IO (RecvState IO)
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (Context -> Handshake -> IO (RecvState IO)
forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx)
processCertificateRequest Context
ctx Handshake
p = do
    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata Maybe CertReqCBdata
forall a. Maybe a
Nothing
    Context -> Handshake -> IO (RecvState IO)
forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
ctx Handshake
p

processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
processServerHelloDone Context
_ Handshake
ServerHelloDone = RecvState m -> IO (RecvState m)
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState m
forall (m :: * -> *). RecvState m
RecvStateDone
processServerHelloDone Context
_ Handshake
p = String -> Maybe String -> IO (RecvState m)
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake -> String
forall a. Show a => a -> String
show Handshake
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"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 (Cipher -> CipherChoice) -> IO Cipher -> IO CipherChoice
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> HandshakeM Cipher -> IO Cipher
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 = SecretTriple HandshakeSecret -> BaseSecret HandshakeSecret
forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
hkey
        clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
clientHandshakeSecret = SecretTriple HandshakeSecret -> ClientTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
hkey
        serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
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 (ClientState -> IO ()) -> ClientState -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeSecretInfo -> ClientState
RecvServerHello HandshakeSecretInfo
handSecInfo
    (Bool
rtt0accepted,[ExtensionRaw]
eexts) <- RecvHandshake13M IO (Bool, [ExtensionRaw])
-> IO (Bool, [ExtensionRaw])
forall (m :: * -> *) a. MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 (RecvHandshake13M IO (Bool, [ExtensionRaw])
 -> IO (Bool, [ExtensionRaw]))
-> RecvHandshake13M IO (Bool, [ExtensionRaw])
-> IO (Bool, [ExtensionRaw])
forall a b. (a -> b) -> a -> b
$ do
        (Bool, [ExtensionRaw])
accext <- Context
-> (Handshake13 -> RecvHandshake13M IO (Bool, [ExtensionRaw]))
-> RecvHandshake13M IO (Bool, [ExtensionRaw])
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx Handshake13 -> RecvHandshake13M IO (Bool, [ExtensionRaw])
forall (m :: * -> *).
MonadIO m =>
Handshake13 -> m (Bool, [ExtensionRaw])
expectEncryptedExtensions
        Bool -> RecvHandshake13M IO () -> RecvHandshake13M IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
resuming (RecvHandshake13M IO () -> RecvHandshake13M IO ())
-> RecvHandshake13M IO () -> RecvHandshake13M IO ()
forall a b. (a -> b) -> a -> b
$ Context
-> (Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a
recvHandshake13 Context
ctx Handshake13 -> RecvHandshake13M IO ()
forall (m :: * -> *).
MonadIO m =>
Handshake13 -> RecvHandshake13M m ()
expectCertRequest
        Context
-> (SessionID -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (SessionID -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx ((SessionID -> Handshake13 -> RecvHandshake13M IO ())
 -> RecvHandshake13M IO ())
-> (SessionID -> Handshake13 -> RecvHandshake13M IO ())
-> RecvHandshake13M IO ()
forall a b. (a -> b) -> a -> b
$ ServerTrafficSecret HandshakeSecret
-> SessionID -> Handshake13 -> RecvHandshake13M IO ()
forall (m :: * -> *) a.
MonadIO m =>
ServerTrafficSecret a -> SessionID -> Handshake13 -> m ()
expectFinished ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        (Bool, [ExtensionRaw])
-> RecvHandshake13M IO (Bool, [ExtensionRaw])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool, [ExtensionRaw])
accext
    SessionID
hChSf <- Context -> IO SessionID
forall (m :: * -> *). MonadIO m => Context -> m SessionID
transcriptHash Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Context -> Bool
ctxQUICMode Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Context -> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall b. Monoid b => PacketFlightM b ()) -> IO ())
-> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> PacketFlightM b ()
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
rtt0accepted Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Context -> Packet13 -> IO ()
sendPacket13 Context
ctx ([Handshake13] -> Packet13
Handshake13 [Handshake13
EndOfEarlyData13])
    Context
-> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
    ClientParams
-> Context -> Hash -> ClientTrafficSecret HandshakeSecret -> IO ()
forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
    SecretTriple ApplicationSecret
appKey <- BaseSecret HandshakeSecret
-> SessionID -> IO (SecretTriple ApplicationSecret)
switchToApplicationSecret BaseSecret HandshakeSecret
handshakeSecret SessionID
hChSf
    let applicationSecret :: BaseSecret ApplicationSecret
applicationSecret = SecretTriple ApplicationSecret -> BaseSecret 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 (SecretTriple ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey, SecretTriple ApplicationSecret
-> ServerTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey)
    Context -> ClientState -> IO ()
contextSync Context
ctx (ClientState -> IO ()) -> ClientState -> IO ()
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
        Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
        SessionID
ecdhe <- IO SessionID
calcSharedKey
        (BaseSecret EarlySecret
earlySecret, Bool
resuming) <- IO (BaseSecret EarlySecret, Bool)
makeEarlySecret
        SecretTriple HandshakeSecret
handKey <- Context
-> CipherChoice
-> BaseSecret EarlySecret
-> SessionID
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret Context
ctx CipherChoice
choice BaseSecret EarlySecret
earlySecret SessionID
ecdhe
        let serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
handKey
        Context
-> Hash -> Cipher -> ServerTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        (Cipher, SecretTriple HandshakeSecret, Bool)
-> IO (Cipher, SecretTriple HandshakeSecret, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cipher
usedCipher, SecretTriple HandshakeSecret
handKey, Bool
resuming)

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

    calcSharedKey :: IO SessionID
calcSharedKey = do
        KeyShareEntry
serverKeyShare <- do
            Maybe KeyShare
mks <- Context -> TLSSt (Maybe KeyShare) -> IO (Maybe KeyShare)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
            case Maybe KeyShare
mks of
              Just (KeyShareServerHello KeyShareEntry
ks) -> KeyShareEntry -> IO KeyShareEntry
forall (m :: * -> *) a. Monad m => a -> m a
return KeyShareEntry
ks
              Just KeyShare
_                        -> String -> IO KeyShareEntry
forall a. HasCallStack => String -> a
error String
"calcSharedKey: invalid KeyShare value"
              Maybe KeyShare
Nothing                       -> TLSError -> IO KeyShareEntry
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO KeyShareEntry) -> TLSError -> IO KeyShareEntry
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"key exchange not implemented, expected key_share extension", Bool
True, AlertDescription
HandshakeFailure)
        let grp :: Group
grp = KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
serverKeyShare
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Group
groupSent Maybe Group -> Maybe Group -> Bool
forall a. Eq a => a -> a -> Bool
== Group -> Maybe Group
forall a. a -> Maybe a
Just Group
grp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"received incompatible group for (EC)DHE", Bool
True, AlertDescription
IllegalParameter)
        Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setNegotiatedGroup Group
grp
        Context -> HandshakeM GroupPrivate -> IO GroupPrivate
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM GroupPrivate
getGroupPrivate IO GroupPrivate -> (GroupPrivate -> IO SessionID) -> IO SessionID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyShareEntry -> GroupPrivate -> IO SessionID
fromServerKeyShare KeyShareEntry
serverKeyShare

    makeEarlySecret :: IO (BaseSecret EarlySecret, Bool)
makeEarlySecret = do
         Maybe (BaseSecret EarlySecret)
mEarlySecretPSK <- Context
-> HandshakeM (Maybe (BaseSecret EarlySecret))
-> IO (Maybe (BaseSecret EarlySecret))
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 -> (BaseSecret EarlySecret, Bool) -> IO (BaseSecret EarlySecret, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe SessionID -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice Maybe SessionID
forall a. Maybe a
Nothing, Bool
False)
           Just earlySecretPSK :: BaseSecret EarlySecret
earlySecretPSK@(BaseSecret SessionID
sec) -> do
               Maybe PreSharedKey
mSelectedIdentity <- Context -> TLSSt (Maybe PreSharedKey) -> IO (Maybe PreSharedKey)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe PreSharedKey)
getTLS13PreSharedKey
               case Maybe PreSharedKey
mSelectedIdentity of
                 Maybe PreSharedKey
Nothing                          ->
                     (BaseSecret EarlySecret, Bool) -> IO (BaseSecret EarlySecret, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (CipherChoice -> Maybe SessionID -> BaseSecret EarlySecret
initEarlySecret CipherChoice
choice Maybe SessionID
forall a. Maybe a
Nothing, Bool
False)
                 Just (PreSharedKeyServerHello Int
0) -> do
                     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SessionID -> Int
B.length SessionID
sec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hashSize) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                         TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"selected cipher is incompatible with selected PSK", Bool
True, AlertDescription
IllegalParameter)
                     Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
PreSharedKey
                     (BaseSecret EarlySecret, Bool) -> IO (BaseSecret EarlySecret, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseSecret EarlySecret
earlySecretPSK, Bool
True)
                 Just PreSharedKey
_                           -> TLSError -> IO (BaseSecret EarlySecret, Bool)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (BaseSecret EarlySecret, Bool))
-> TLSError -> IO (BaseSecret EarlySecret, Bool)
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
        IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTEncryptedExtensions [ExtensionRaw]
eexts
        RTT0Status
st <- Context -> HandshakeM RTT0Status -> m RTT0Status
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM RTT0Status
getTLS13RTT0Status
        if RTT0Status
st RTT0Status -> RTT0Status -> Bool
forall a. Eq a => a -> a -> Bool
== RTT0Status
RTT0Sent then
            case ExtensionID -> [ExtensionRaw] -> Maybe SessionID
extensionLookup ExtensionID
extensionID_EarlyData [ExtensionRaw]
eexts of
              Just SessionID
_  -> do
                  Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
RTT0
                  Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Accepted
                  (Bool, [ExtensionRaw]) -> m (Bool, [ExtensionRaw])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True,[ExtensionRaw]
eexts)
              Maybe SessionID
Nothing -> do
                  Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
RTT0
                  Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Rejected
                  (Bool, [ExtensionRaw]) -> m (Bool, [ExtensionRaw])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
          else
            (Bool, [ExtensionRaw]) -> m (Bool, [ExtensionRaw])
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False,[ExtensionRaw]
eexts)
    expectEncryptedExtensions Handshake13
p = String -> Maybe String -> m (Bool, [ExtensionRaw])
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"encrypted extensions")

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

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

    expectCertAndVerify :: Handshake13 -> RecvHandshake13M m ()
expectCertAndVerify (Certificate13 SessionID
_ CertificateChain
cc [[ExtensionRaw]]
_) = do
        RecvState IO
_ <- IO (RecvState IO) -> RecvHandshake13M m (RecvState IO)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (RecvState IO) -> RecvHandshake13M m (RecvState IO))
-> IO (RecvState IO) -> RecvHandshake13M m (RecvState IO)
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 (Certificate -> PubKey) -> Certificate -> PubKey
forall a b. (a -> b) -> a -> b
$ SignedExact Certificate -> Certificate
getCertificate (SignedExact Certificate -> Certificate)
-> SignedExact Certificate -> Certificate
forall a b. (a -> b) -> a -> b
$ CertificateChain -> SignedExact Certificate
getCertificateChainLeaf CertificateChain
cc
        Version
ver <- IO Version -> RecvHandshake13M m Version
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Version -> RecvHandshake13M m Version)
-> IO Version -> RecvHandshake13M m Version
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
        Version -> PubKey -> RecvHandshake13M m ()
forall (m :: * -> *). MonadIO m => Version -> PubKey -> m ()
checkDigitalSignatureKey Version
ver PubKey
pubkey
        Context -> HandshakeM () -> RecvHandshake13M m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> RecvHandshake13M m ())
-> HandshakeM () -> RecvHandshake13M m ()
forall a b. (a -> b) -> a -> b
$ PubKey -> HandshakeM ()
setPublicKey PubKey
pubkey
        Context
-> (SessionID -> Handshake13 -> RecvHandshake13M m ())
-> RecvHandshake13M m ()
forall (m :: * -> *) a.
MonadIO m =>
Context
-> (SessionID -> Handshake13 -> RecvHandshake13M m a)
-> RecvHandshake13M m a
recvHandshake13hash Context
ctx ((SessionID -> Handshake13 -> RecvHandshake13M m ())
 -> RecvHandshake13M m ())
-> (SessionID -> Handshake13 -> RecvHandshake13M m ())
-> RecvHandshake13M m ()
forall a b. (a -> b) -> a -> b
$ PubKey -> SessionID -> Handshake13 -> RecvHandshake13M m ()
forall (m :: * -> *).
MonadIO m =>
PubKey -> SessionID -> Handshake13 -> m ()
expectCertVerify PubKey
pubkey
    expectCertAndVerify Handshake13
p = String -> Maybe String -> RecvHandshake13M m ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
p) (String -> Maybe String
forall a. a -> Maybe a
Just String
"server certificate")

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

    expectFinished :: ServerTrafficSecret a -> SessionID -> Handshake13 -> m ()
expectFinished (ServerTrafficSecret SessionID
baseKey) SessionID
hashValue (Finished13 SessionID
verifyData) =
        Hash -> SessionID -> SessionID -> SessionID -> m ()
forall (m :: * -> *).
MonadIO m =>
Hash -> SessionID -> SessionID -> SessionID -> m ()
checkFinished Hash
usedHash SessionID
baseKey SessionID
hashValue SessionID
verifyData
    expectFinished ServerTrafficSecret a
_ SessionID
_ Handshake13
p = String -> Maybe String -> m ()
forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
unexpected (Handshake13 -> String
forall a. Show a => a -> String
show Handshake13
p) (String -> Maybe String
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
        Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ BaseSecret ResumptionSecret -> HandshakeM ()
setTLS13ResumptionSecret BaseSecret ResumptionSecret
resumptionSecret

processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()
processCertRequest13 :: Context -> SessionID -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx SessionID
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 <- ExtensionID
-> (SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm])
-> m (Maybe [HashAndSignatureAlgorithm])
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 = (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 [HashAndSignatureAlgorithm]
as
             in [CertificateType] -> m [CertificateType]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CertificateType] -> m [CertificateType])
-> [CertificateType] -> m [CertificateType]
forall a b. (a -> b) -> a -> b
$ Context -> [HashAndSignatureAlgorithm] -> [CertificateType]
sigAlgsToCertTypes Context
ctx [HashAndSignatureAlgorithm]
validAs
        Maybe [HashAndSignatureAlgorithm]
Nothing -> TLSError -> m [CertificateType]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m [CertificateType])
-> TLSError -> m [CertificateType]
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
    Context -> HandshakeM () -> m ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> m ()) -> HandshakeM () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe SessionID -> HandshakeM ()
setCertReqToken  (Maybe SessionID -> HandshakeM ())
-> Maybe SessionID -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ SessionID -> Maybe SessionID
forall a. a -> Maybe a
Just SessionID
token
        Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata (Maybe CertReqCBdata -> HandshakeM ())
-> Maybe CertReqCBdata -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ CertReqCBdata -> Maybe CertReqCBdata
forall a. a -> Maybe a
Just ([CertificateType]
cTypes, Maybe [HashAndSignatureAlgorithm]
hsAlgs, [DistinguishedName]
dNames)
        -- setCertReqSigAlgsCert caAlgs
  where
    canames :: m [DistinguishedName]
canames = case ExtensionID -> [ExtensionRaw] -> Maybe SessionID
extensionLookup
                   ExtensionID
extensionID_CertificateAuthorities [ExtensionRaw]
exts of
        Maybe SessionID
Nothing   -> [DistinguishedName] -> m [DistinguishedName]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just  SessionID
ext -> case MessageType -> SessionID -> Maybe CertificateAuthorities
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest SessionID
ext of
                         Just (CertificateAuthorities [DistinguishedName]
names) -> [DistinguishedName] -> m [DistinguishedName]
forall (m :: * -> *) a. Monad m => a -> m a
return [DistinguishedName]
names
                         Maybe CertificateAuthorities
_ -> TLSError -> m [DistinguishedName]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m [DistinguishedName])
-> TLSError -> m [DistinguishedName]
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 SessionID
extensionLookup ExtensionID
extID [ExtensionRaw]
exts of
        Maybe SessionID
Nothing   -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        Just  SessionID
ext -> case MessageType -> SessionID -> Maybe t
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
MsgTCertificateRequest SessionID
ext of
                         Just t
e
                           -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return    (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ t -> Maybe a
decons t
e
                         Maybe t
_ -> TLSError -> m (Maybe a)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m (Maybe a)) -> TLSError -> m (Maybe a)
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) = [HashAndSignatureAlgorithm] -> Maybe [HashAndSignatureAlgorithm]
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 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (ClientTrafficSecret SessionID
baseKey) = do
    Maybe CertificateChain
chain <- ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx
    Context -> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall b. Monoid b => PacketFlightM b ()) -> IO ())
-> (forall b. Monoid b => PacketFlightM b ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        case Maybe CertificateChain
chain of
            Maybe CertificateChain
Nothing -> () -> PacketFlightM b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just CertificateChain
cc -> Context
-> HandshakeM (Maybe SessionID)
-> PacketFlightM b (Maybe SessionID)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe SessionID)
getCertReqToken PacketFlightM b (Maybe SessionID)
-> (Maybe SessionID -> PacketFlightM b ()) -> PacketFlightM b ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CertificateChain -> Maybe SessionID -> PacketFlightM b ()
forall b.
Monoid b =>
CertificateChain -> Maybe SessionID -> PacketFlightM b ()
sendClientData13 CertificateChain
cc
        Handshake13
rawFinished <- Context -> Hash -> SessionID -> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> SessionID -> m Handshake13
makeFinished Context
ctx Hash
usedHash SessionID
baseKey
        Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
rawFinished]
  where
    sendClientData13 :: CertificateChain -> Maybe SessionID -> PacketFlightM b ()
sendClientData13 CertificateChain
chain (Just SessionID
token) = do
        let (CertificateChain [SignedExact Certificate]
certs) = CertificateChain
chain
            certExts :: [[a]]
certExts = Int -> [a] -> [[a]]
forall a. Int -> a -> [a]
replicate ([SignedExact Certificate] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
certs) []
            cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 ([HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm])
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
        Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [SessionID -> CertificateChain -> [[ExtensionRaw]] -> Handshake13
Certificate13 SessionID
token CertificateChain
chain [[ExtensionRaw]]
forall a. [[a]]
certExts]
        case [SignedExact Certificate]
certs of
            [] -> () -> PacketFlightM b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [SignedExact Certificate]
_  -> do
                  SessionID
hChSc      <- Context -> PacketFlightM b SessionID
forall (m :: * -> *). MonadIO m => Context -> m SessionID
transcriptHash Context
ctx
                  PubKey
pubKey     <- Context -> PacketFlightM b PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
                  HashAndSignatureAlgorithm
sigAlg     <- IO HashAndSignatureAlgorithm
-> PacketFlightM b HashAndSignatureAlgorithm
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HashAndSignatureAlgorithm
 -> PacketFlightM b HashAndSignatureAlgorithm)
-> IO HashAndSignatureAlgorithm
-> PacketFlightM b HashAndSignatureAlgorithm
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        <- Context
-> PubKey
-> HashAndSignatureAlgorithm
-> SessionID
-> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> SessionID
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubKey HashAndSignatureAlgorithm
sigAlg SessionID
hChSc
                  Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
vfy]
    --
    sendClientData13 CertificateChain
_ Maybe SessionID
_ =
        TLSError -> PacketFlightM b ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> PacketFlightM b ()) -> TLSError -> PacketFlightM b ()
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 SessionID
extensionLookup ExtensionID
extensionID_ApplicationLayerProtocolNegotiation [ExtensionRaw]
exts Maybe SessionID
-> (SessionID -> Maybe ApplicationLayerProtocolNegotiation)
-> Maybe ApplicationLayerProtocolNegotiation
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType
-> SessionID -> Maybe ApplicationLayerProtocolNegotiation
forall a. Extension a => MessageType -> SessionID -> Maybe a
extensionDecode MessageType
msgt of
    Just (ApplicationLayerProtocolNegotiation [SessionID
proto]) -> Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe [SessionID]
mprotos <- TLSSt (Maybe [SessionID])
getClientALPNSuggest
        case Maybe [SessionID]
mprotos of
            Just [SessionID]
protos -> Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SessionID
proto SessionID -> [SessionID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SessionID]
protos) (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ do
                Bool -> TLSSt ()
setExtensionALPN Bool
True
                SessionID -> TLSSt ()
setNegotiatedProtocol SessionID
proto
            Maybe [SessionID]
_ -> () -> TLSSt ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ApplicationLayerProtocolNegotiation
_ -> () -> IO ()
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 SessionID
certReqCtx [ExtensionRaw]
exts) =
    IO (Saved (Maybe HandshakeState))
-> (Saved (Maybe HandshakeState)
    -> IO (Saved (Maybe HandshakeState)))
-> (Saved (Maybe HandshakeState) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx) (Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx) ((Saved (Maybe HandshakeState) -> IO ()) -> IO ())
-> (Saved (Maybe HandshakeState) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Saved (Maybe HandshakeState)
_ -> do
        Context -> Handshake13 -> IO ()
processHandshake13 Context
ctx Handshake13
h
        Context -> SessionID -> [ExtensionRaw] -> IO ()
forall (m :: * -> *).
MonadIO m =>
Context -> SessionID -> [ExtensionRaw] -> m ()
processCertRequest13 Context
ctx SessionID
certReqCtx [ExtensionRaw]
exts
        (Hash
usedHash, Cipher
_, CryptLevel
level, SessionID
applicationSecretN) <- Context -> IO (Hash, Cipher, CryptLevel, SessionID)
getTxState Context
ctx
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CryptLevel
level CryptLevel -> CryptLevel -> Bool
forall a. Eq a => a -> a -> Bool
== CryptLevel
CryptApplicationSecret) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected post-handshake authentication request", Bool
True, AlertDescription
UnexpectedMessage)
        ClientParams -> Context -> Hash -> ClientTrafficSecret Any -> IO ()
forall a.
ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO ()
sendClientFlight13 ClientParams
cparams Context
ctx Hash
usedHash (SessionID -> ClientTrafficSecret Any
forall a. SessionID -> ClientTrafficSecret a
ClientTrafficSecret SessionID
applicationSecretN)

postHandshakeAuthClientWith ClientParams
_ Context
_ Handshake13
_ =
    TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Bool, AlertDescription) -> TLSError
Error_Protocol (String
"unexpected handshake message received in 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