{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Server.ClientHello (
processClientHello,
) where
import Network.TLS.Compression
import Network.TLS.Context.Internal
import Network.TLS.Extension
import Network.TLS.Handshake.Process
import Network.TLS.Imports
import Network.TLS.Measurement
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types
processClientHello
:: ServerParams -> Context -> Handshake -> IO (Version, CH)
processClientHello :: ServerParams -> Context -> Handshake -> IO (Version, CH)
processClientHello ServerParams
sparams Context
ctx clientHello :: Handshake
clientHello@(ClientHello Version
legacyVersion ClientRandom
cran [CompressionID]
compressions ch :: CH
ch@CH{[CipherId]
[ExtensionRaw]
Session
chSession :: Session
chCiphers :: [CipherId]
chExtensions :: [ExtensionRaw]
chExtensions :: CH -> [ExtensionRaw]
chCiphers :: CH -> [CipherId]
chSession :: CH -> Session
..}) = do
established <- Context -> IO Established
ctxEstablished Context
ctx
when (established /= NotEstablished) $ do
ver <- usingState_ ctx (getVersionWithDefault TLS12)
when (ver == TLS13) $
throwCore $
Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage
eof <- ctxEOF ctx
let renegotiation = Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof
when
(renegotiation && not (supportedClientInitiatedRenegotiation $ ctxSupported ctx))
$ throwCore
$ Error_Protocol_Warning "renegotiation is not allowed" NoRenegotiation
handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)
unless
handshakeAuthorized
(throwCore $ Error_HandshakePolicy "server: handshake denied")
updateMeasure ctx incrementNbHandshakes
hrr <- usingState_ ctx getTLS13HRR
unless hrr $ startHandshake ctx legacyVersion cran
processHandshake12 ctx clientHello
when (legacyVersion /= TLS12) $
throwCore $
Error_Protocol (show legacyVersion ++ " is not supported") ProtocolVersion
when
( supportedFallbackScsv (ctxSupported ctx)
&& (CipherId 0x5600 `elem` chCiphers)
&& legacyVersion < TLS12
)
$ throwCore
$ Error_Protocol "fallback is not allowed" InappropriateFallback
let extract (SupportedVersionsClientHello [Version]
vers) = [Version]
vers
extract SupportedVersions
_ = []
clientVersions = ExtensionID
-> MessageType
-> [ExtensionRaw]
-> [Version]
-> (SupportedVersions -> [Version])
-> [Version]
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode ExtensionID
EID_SupportedVersions MessageType
MsgTClientHello [ExtensionRaw]
chExtensions [] SupportedVersions -> [Version]
extract
clientVersion = Version -> Version -> Version
forall a. Ord a => a -> a -> a
min Version
TLS12 Version
legacyVersion
serverVersions
| Bool
renegotiation = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (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)
| Bool
otherwise = Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
mVersion = DebugParams -> Maybe Version
debugVersionForced (DebugParams -> Maybe Version) -> DebugParams -> Maybe Version
forall a b. (a -> b) -> a -> b
$ ServerParams -> DebugParams
serverDebug ServerParams
sparams
chosenVersion <- case mVersion of
Just Version
cver -> Version -> IO Version
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Version
cver
Maybe Version
Nothing ->
if (Version
TLS13 Version -> [Version] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Version]
serverVersions) Bool -> Bool -> Bool
&& [Version]
clientVersions [Version] -> [Version] -> Bool
forall a. Eq a => a -> a -> Bool
/= []
then case [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 [Version]
clientVersions [Version]
serverVersions of
Maybe Version
Nothing ->
TLSError -> IO Version
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Version) -> TLSError -> IO Version
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
(String
"client versions " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Version] -> String
forall a. Show a => a -> String
show [Version]
clientVersions String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not supported")
AlertDescription
ProtocolVersion
Just Version
v -> Version -> IO Version
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
else case Version -> [Version] -> Maybe Version
findHighestVersionFrom Version
clientVersion [Version]
serverVersions of
Maybe Version
Nothing ->
TLSError -> IO Version
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Version) -> TLSError -> IO Version
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
(String
"client version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
clientVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not supported")
AlertDescription
ProtocolVersion
Just Version
v -> Version -> IO Version
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Version
v
let extractServerName (ServerName [ServerNameType]
ns) = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ((ServerNameType -> Maybe String) -> [ServerNameType] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ServerNameType -> Maybe String
toHostName [ServerNameType]
ns)
toHostName (ServerNameHostName String
hostName) = String -> Maybe String
forall a. a -> Maybe a
Just String
hostName
toHostName (ServerNameOther (CompressionID, ByteString)
_) = Maybe String
forall a. Maybe a
Nothing
serverName =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Maybe String
-> (ServerName -> Maybe String)
-> Maybe String
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_ServerName
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
Maybe String
forall a. Maybe a
Nothing
ServerName -> Maybe String
extractServerName
let nullComp = Compression -> CompressionID
compressionID Compression
nullCompression
case chosenVersion of
Version
TLS13 ->
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([CompressionID]
compressions [CompressionID] -> [CompressionID] -> Bool
forall a. Eq a => a -> a -> Bool
/= [CompressionID
nullComp]) (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
"compression is not allowed in TLS 1.3" AlertDescription
IllegalParameter
Version
_ -> case (CompressionID -> Bool) -> [CompressionID] -> Maybe CompressionID
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
== CompressionID
nullComp) [CompressionID]
compressions of
Maybe CompressionID
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
"compressions must include nullCompression in TLS 1.2"
AlertDescription
IllegalParameter
Maybe CompressionID
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybe (return ()) (usingState_ ctx . setClientSNI) serverName
return (chosenVersion, ch)
processClientHello ServerParams
_ Context
_ Handshake
_ =
TLSError -> IO (Version, CH)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (Version, CH)) -> TLSError -> IO (Version, CH)
forall a b. (a -> b) -> a -> b
$
String -> AlertDescription -> TLSError
Error_Protocol
String
"unexpected handshake message received in handshakeServerWith"
AlertDescription
HandshakeFailure
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom :: Version -> [Version] -> Maybe Version
findHighestVersionFrom Version
clientVersion [Version]
allowedVersions =
case (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version
clientVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>=) ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (Version -> Down Version) -> [Version] -> [Version]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Version -> Down Version
forall a. a -> Down a
Down [Version]
allowedVersions of
[] -> Maybe Version
forall a. Maybe a
Nothing
Version
v : [Version]
_ -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 :: [Version] -> [Version] -> Maybe Version
findHighestVersionFrom13 [Version]
clientVersions [Version]
serverVersions = case [Version]
svs [Version] -> [Version] -> [Version]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Version]
cvs of
[] -> Maybe Version
forall a. Maybe a
Nothing
Version
v : [Version]
_ -> Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
where
svs :: [Version]
svs = (Version -> Down Version) -> [Version] -> [Version]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Version -> Down Version
forall a. a -> Down a
Down [Version]
serverVersions
cvs :: [Version]
cvs = (Version -> Down Version) -> [Version] -> [Version]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Version -> Down Version
forall a. a -> Down a
Down ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
TLS12) [Version]
clientVersions