{-# LANGUAGE OverloadedStrings #-}
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 -> 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 -> AlertDescription -> TLSError
Error_Protocol
String
"unexpected handshake message received in handshakeClientWith"
AlertDescription
HandshakeFailure
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient ClientParams
cparams Context
ctx = do
groups <- case ClientParams -> [(SessionID, SessionData)]
clientSessions ClientParams
cparams of
[] -> [Group] -> IO [Group]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Group]
groupsSupported
(SessionID
_, SessionData
sdata) : [(SessionID, SessionData)]
_ -> case SessionData -> Maybe Group
sessionGroup SessionData
sdata of
Maybe Group
Nothing -> [Group] -> IO [Group]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
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 -> [Group] -> IO [Group]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Group] -> IO [Group]) -> [Group] -> IO [Group]
forall a b. (a -> b) -> a -> b
$ 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
| Bool
otherwise -> TLSError -> IO [Group]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO [Group]) -> TLSError -> IO [Group]
forall a b. (a -> b) -> a -> b
$ String -> TLSError
Error_Misc String
"groupsSupported is incorrect"
handshake cparams ctx groups Nothing
where
groupsSupported :: [Group]
groupsSupported = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
handshake
:: ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshake :: ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshake ClientParams
cparams Context
ctx [Group]
groups Maybe (ClientRandom, Session, Version)
mparams = do
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 groupToSend chSentTime
updateMeasure ctx incrementNbHandshakes
crand <- sendClientHello cparams ctx groups mparams pskinfo
unless async $ do
(ver, hss, hrr) <- receiveServerHello cparams ctx mparams
case ver of
Version
TLS13
| Bool
hrr ->
ClientParams
-> Context
-> Maybe (ClientRandom, Session, Version)
-> Version
-> ClientRandom
-> [Group]
-> IO ()
forall a.
ClientParams
-> Context
-> Maybe a
-> Version
-> ClientRandom
-> [Group]
-> IO ()
helloRetry ClientParams
cparams Context
ctx Maybe (ClientRandom, Session, Version)
mparams Version
ver ClientRandom
crand ([Group] -> IO ()) -> [Group] -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> [Group] -> [Group]
forall a. Int -> [a] -> [a]
drop Int
1 [Group]
groups
| Bool
otherwise -> do
ClientParams -> Context -> Maybe Group -> IO ()
recvServerSecondFlight13 ClientParams
cparams Context
ctx Maybe Group
groupToSend
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 -> [Handshake] -> IO ()
recvServerFirstFlight12 ClientParams
cparams Context
ctx [Handshake]
hss
ClientParams -> Context -> IO ()
sendClientSecondFlight12 ClientParams
cparams Context
ctx
ClientParams -> Context -> IO ()
recvServerSecondFlight12 ClientParams
cparams Context
ctx
where
groupToSend :: Maybe Group
groupToSend = [Group] -> Maybe Group
forall a. [a] -> Maybe a
listToMaybe [Group]
groups
receiveServerHello
:: ClientParams
-> Context
-> Maybe (ClientRandom, Session, Version)
-> IO (Version, [Handshake], Bool)
receiveServerHello :: ClientParams
-> Context
-> Maybe (ClientRandom, Session, Version)
-> IO (Version, [Handshake], Bool)
receiveServerHello ClientParams
cparams Context
ctx Maybe (ClientRandom, Session, Version)
mparams = do
chSentTime <- IO Millisecond
getCurrentTimeFromBase
hss <- recvServerHello cparams ctx
setRTT ctx chSentTime
ver <- usingState_ ctx getVersion
unless (maybe True (\(ClientRandom
_, Session
_, Version
v) -> Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ver) mparams) $
throwCore $
Error_Protocol "version changed after hello retry" IllegalParameter
hrr <- usingState_ ctx getTLS13HRR
return (ver, hss, hrr)
helloRetry
:: ClientParams
-> Context
-> Maybe a
-> Version
-> ClientRandom
-> [Group]
-> IO ()
helloRetry :: forall a.
ClientParams
-> Context
-> Maybe a
-> Version
-> ClientRandom
-> [Group]
-> IO ()
helloRetry ClientParams
cparams Context
ctx Maybe a
mparams Version
ver ClientRandom
crand [Group]
groups = 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]
groups) (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
"group is exhausted in 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)
| 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]
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 ()
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
handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, 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 -> 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