{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TLS.Handshake.Client (
    handshakeClient,
    handshakeClientWith,
    postHandshakeAuthClientWith,
) where

import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Client.ClientHello
import Network.TLS.Handshake.Client.Common
import Network.TLS.Handshake.Client.ServerHello
import Network.TLS.Handshake.Client.TLS12
import Network.TLS.Handshake.Client.TLS13
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Measurement
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct

----------------------------------------------------------------

handshakeClientWith
    :: ClientParams -> Context -> HandshakeR -> IO ()
handshakeClientWith :: ClientParams -> Context -> HandshakeR -> IO ()
handshakeClientWith ClientParams
cparams Context
ctx (Handshake
HelloRequest, WireBytes
_b) = ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx -- xxx
handshakeClientWith ClientParams
_ Context
_ HandshakeR
_ =
    TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
        String -> AlertDescription -> TLSError
Error_Protocol
            String
"unexpected handshake message received in handshakeClientWith"
            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
    grps <- case ClientParams -> [(SessionID, SessionData)]
clientSessions ClientParams
cparams of
        [] ->
            Groups -> IO Groups
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Groups -> IO Groups) -> Groups -> IO Groups
forall a b. (a -> b) -> a -> b
$
                Groups
                    { grpsSupported :: [Group]
grpsSupported = [Group]
groupsSupported
                    , grpsSelected :: [Group]
grpsSelected = [Group]
groupsSelected
                    }
        (SessionID
_, SessionData
sdata) : [(SessionID, SessionData)]
_ -> case SessionData -> Maybe Group
sessionGroup SessionData
sdata of
            Maybe Group
Nothing ->
                -- TLS 1.2 or earlier
                Groups -> IO Groups
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Groups -> IO Groups) -> Groups -> IO Groups
forall a b. (a -> b) -> a -> b
$
                    Groups
                        { grpsSupported :: [Group]
grpsSupported = [Group]
groupsSupported -- for ciphers
                        , grpsSelected :: [Group]
grpsSelected = []
                        }
            Just Group
grp
                | Group
grp Group -> [Group] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groupsSupported -> do
                    let supported :: [Group]
supported = 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
                    Groups -> IO Groups
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Groups -> IO Groups) -> Groups -> IO Groups
forall a b. (a -> b) -> a -> b
$
                        Groups
                            { grpsSupported :: [Group]
grpsSupported = [Group]
supported
                            , grpsSelected :: [Group]
grpsSelected = [Group
grp]
                            }
                | Bool
otherwise -> TLSError -> IO Groups
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Groups) -> TLSError -> IO Groups
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc String
"groupsSupported is incorrect"
    handshake cparams ctx grps Nothing
  where
    groupsSupported :: [Group]
groupsSupported = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
    groupsSelected :: [Group]
groupsSelected = ClientHooks -> [Group] -> [Group]
onSelectKeyShareGroups (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) [Group]
groupsSupported

-- 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.
handshake
    :: ClientParams
    -> Context
    -> Groups
    -> Maybe (ClientRandom, Session, Version)
    -> IO ()
handshake :: ClientParams
-> Context
-> Groups
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshake ClientParams
cparams Context
ctx grps :: Groups
grps@Groups{[Group]
grpsSupported :: Groups -> [Group]
grpsSelected :: Groups -> [Group]
grpsSupported :: [Group]
grpsSelected :: [Group]
..} Maybe (ClientRandom, Session, Version)
mparams = do
    --------------------------------
    -- Sending ClientHello
    pskinfo@(_, _, rtt0) <- ClientParams -> Context -> IO PreSharedKeyInfo
getPreSharedKeyInfo ClientParams
cparams Context
ctx
    when rtt0 $ modifyTLS13State ctx $ \TLS13State
st -> TLS13State
st{tls13st0RTT = True}
    let async = Bool
rtt0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
    when async $ do
        chSentTime <- getCurrentTimeFromBase
        asyncServerHello13 cparams ctx grpsSelected chSentTime
    updateMeasure ctx incrementNbHandshakes
    crand <-
        sendClientHello cparams ctx grps mparams pskinfo
    --------------------------------
    -- Receiving ServerHello
    unless async $ do
        (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams
        -- Switching to HRR, TLS 1.2 or TLS 1.3
        case ver of
            Version
TLS13
                | Bool
hrr ->
                    ClientParams
-> Context
-> Maybe (ClientRandom, Session, Version)
-> Version
-> ClientRandom
-> [Group]
-> [Group]
-> IO ()
forall a.
ClientParams
-> Context
-> Maybe a
-> Version
-> ClientRandom
-> [Group]
-> [Group]
-> IO ()
helloRetry ClientParams
cparams Context
ctx Maybe (ClientRandom, Session, Version)
mparams Version
ver ClientRandom
crand [Group]
grpsSupported [Group]
grpsSelected
                | Bool
otherwise -> do
                    ClientParams -> Context -> [Group] -> IO ()
recvServerSecondFlight13 ClientParams
cparams Context
ctx [Group]
grpsSelected
                    ClientParams -> Context -> IO ()
sendClientSecondFlight13 ClientParams
cparams Context
ctx
            Version
_
                | Bool
rtt0 ->
                    TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
                        String -> AlertDescription -> TLSError
Error_Protocol
                            String
"server denied TLS 1.3 when connecting with early data"
                            AlertDescription
HandshakeFailure
                | Bool
otherwise -> do
                    ClientParams -> Context -> [HandshakeR] -> IO ()
recvServerFirstFlight12 ClientParams
cparams Context
ctx [HandshakeR]
hbs
                    ClientParams -> Context -> IO ()
sendClientSecondFlight12 ClientParams
cparams Context
ctx
                    ClientParams -> Context -> IO ()
recvServerSecondFlight12 ClientParams
cparams Context
ctx

----------------------------------------------------------------

helloRetry
    :: ClientParams
    -> Context
    -> Maybe a
    -> Version
    -> ClientRandom
    -> [Group]
    -> [Group]
    -> IO ()
helloRetry :: forall a.
ClientParams
-> Context
-> Maybe a
-> Version
-> ClientRandom
-> [Group]
-> [Group]
-> IO ()
helloRetry ClientParams
cparams Context
ctx Maybe a
mparams Version
ver ClientRandom
crand [Group]
groupsSupported [Group]
groupsSelected = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Group] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
groupsSupported) (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 -> AlertDescription -> TLSError
Error_Protocol String
"no supported groups on the client side" AlertDescription
IllegalParameter
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
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 -> AlertDescription -> TLSError
Error_Protocol String
"server sent too many hello retries" AlertDescription
UnexpectedMessage
    mks <- Context -> TLSSt (Maybe KeyShare) -> IO (Maybe KeyShare)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe KeyShare)
getTLS13KeyShare
    case mks of
        Just (KeyShareHRR Group
selectedGroup)
            -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups
            -- and MUST NOT already have been offered in the initial key_share.
            | Group
selectedGroup Group -> [Group] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groupsSupported
                Bool -> Bool -> Bool
&& Group
selectedGroup Group -> [Group] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Group]
groupsSelected -> 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 ()
clearTxRecordState Context
ctx
                let cparams' :: ClientParams
cparams' = ClientParams
cparams{clientUseEarlyData = False}
                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
                clientSession <- TLS13State -> Session
tls13stSession (TLS13State -> Session) -> IO TLS13State -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
                -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical
                -- to the first except for the specific listed changes.
                -- supported_groups is NOT on that list, so it must be unchanged.
                let grps =
                        Groups
                            { grpsSupported :: [Group]
grpsSupported = [Group]
groupsSupported
                            , grpsSelected :: [Group]
grpsSelected = [Group
selectedGroup]
                            }

                handshake
                    cparams'
                    ctx
                    grps
                    (Just (crand, clientSession, ver))
            | Group
selectedGroup Group -> [Group] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Group]
groupsSelected ->
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
                    String -> AlertDescription -> TLSError
Error_Protocol
                        String
"server selected a group already offered in key_share"
                        AlertDescription
IllegalParameter
            | 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 -> AlertDescription -> TLSError
Error_Protocol String
"server-selected group is not supported" AlertDescription
IllegalParameter
        Just KeyShare
_ -> String -> IO ()
forall a. HasCallStack => String -> a
error String
"handshake: 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 -> AlertDescription -> TLSError
Error_Protocol
                    String
"key exchange not implemented in HRR, expected key_share extension"
                    AlertDescription
HandshakeFailure