    {-# 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