{-# 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
    -- renego is not allowed in TLS 1.3
    when (established /= NotEstablished) $ do
        ver <- usingState_ ctx (getVersionWithDefault TLS12)
        when (ver == TLS13) $
            throwCore $
                Error_Protocol "renegotiation is not allowed in TLS 1.3" UnexpectedMessage
    -- rejecting client initiated renegotiation to prevent DOS.
    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
    -- check if policy allow this new handshake to happens
    handshakeAuthorized <- withMeasure ctx (onNewHandshake $ serverHooks sparams)
    unless
        handshakeAuthorized
        (throwCore $ Error_HandshakePolicy "server: handshake denied")
    updateMeasure ctx incrementNbHandshakes

    -- Handle Client hello
    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

    -- Fallback SCSV: RFC7507
    -- TLS_FALLBACK_SCSV: {0x56, 0x00}
    when
        ( supportedFallbackScsv (ctxSupported ctx)
            && (CipherId 0x5600 `elem` chCiphers)
            && legacyVersion < TLS12
        )
        $ throwCore
        $ Error_Protocol "fallback is not allowed" InappropriateFallback
    -- choosing TLS version
    let extract (SupportedVersionsClientHello [Version]
vers) = [Version]
vers -- fixme: 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

    -- SNI (Server Name Indication)
    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