    {-# LANGUAGE OverloadedStrings #-}

    module Network.TLS.Handshake.Server (
        handshakeServer,
        handshakeServerWith,
        requestCertificateServer,
        postHandshakeAuthServerWith,
    ) where

    import Control.Exception (bracket)
    import Control.Monad.State.Strict

    import Network.TLS.Context.Internal
    import Network.TLS.Handshake.Common
    import Network.TLS.Handshake.Common13
    import Network.TLS.Handshake.Server.ClientHello
    import Network.TLS.Handshake.Server.ClientHello12
    import Network.TLS.Handshake.Server.ClientHello13
    import Network.TLS.Handshake.Server.ServerHello12
    import Network.TLS.Handshake.Server.ServerHello13
    import Network.TLS.Handshake.Server.TLS12
    import Network.TLS.Handshake.Server.TLS13
    import Network.TLS.IO
    import Network.TLS.Imports
    import Network.TLS.State
    import Network.TLS.Struct
    import Network.TLS.Struct13

    -- Put the server context in handshake mode.
    --
    -- Expect to receive as first packet a client hello handshake message
    --
    -- This is just a helper to pop the next message from the recv layer,
    -- and call handshakeServerWith.
    handshakeServer :: ServerParams -> Context -> IO ()
    handshakeServer :: ServerParams -> Context -> IO ()
    handshakeServer ServerParams
    sparams Context
    ctx = IO () -> IO ()
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
        hss <- Context -> IO [Handshake]
    recvPacketHandshake Context
    ctx
        case hss of
            [Handshake
    ch] -> ServerParams -> Context -> Handshake -> IO ()
    handshake ServerParams
    sparams Context
    ctx Handshake
    ch
            [Handshake]
    _ -> String -> Maybe String -> IO ()
    forall (m :: * -> *) a. MonadIO m => String -> Maybe String -> m a
    unexpected ([Handshake] -> String
    forall a. Show a => a -> String
    show [Handshake]
    hss) (String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "client hello")

    handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
    handshakeServerWith :: ServerParams -> Context -> Handshake -> IO ()
    handshakeServerWith = ServerParams -> Context -> Handshake -> IO ()
    handshake

    -- | Put the server context in handshake mode.
    --
    -- Expect a client hello message as parameter.
    -- This is useful when the client hello has been already poped from the recv layer to inspect the packet.
    --
    -- When the function returns, a new handshake has been succesfully negociated.
    -- On any error, a HandshakeFailed exception is raised.
    handshake :: ServerParams -> Context -> Handshake -> IO ()
    handshake :: ServerParams -> Context -> Handshake -> IO ()
    handshake ServerParams
    sparams Context
    ctx Handshake
    clientHello = do
        (chosenVersion, ch) <- ServerParams -> Context -> Handshake -> IO (Version, CH)
    processClientHello ServerParams
    sparams Context
    ctx Handshake
    clientHello
        if chosenVersion == TLS13
            then do
                -- fixme: we should check if the client random is the same as
                -- that in the first client hello in the case of hello retry.
                (mClientKeyShare, r0) <-
                    processClientHello13 sparams ctx ch
                case mClientKeyShare of
                    Maybe KeyShareEntry
    Nothing -> do
                        Context -> (Cipher, Hash, Bool) -> CH -> IO ()
    forall a b. Context -> (Cipher, a, b) -> CH -> IO ()
    sendHRR Context
    ctx (Cipher, Hash, Bool)
    r0 CH
    ch
                        -- Don't reset ctxEstablished since 0-RTT data
                        -- would be comming, which should be ignored.
                        ServerParams -> Context -> IO ()
    handshakeServer ServerParams
    sparams Context
    ctx
                    Just KeyShareEntry
    cliKeyShare -> do
                        r1 <-
                            ServerParams
    -> Context
    -> KeyShareEntry
    -> (Cipher, Hash, Bool)
    -> CH
    -> IO
         (SecretTriple ApplicationSecret,
          ClientTrafficSecret HandshakeSecret, Bool, Bool)
    sendServerHello13 ServerParams
    sparams Context
    ctx KeyShareEntry
    cliKeyShare (Cipher, Hash, Bool)
    r0 CH
    ch
                        recvClientSecondFlight13 sparams ctx r1 ch
            else do
                r <-
                    processClientHello12 sparams ctx ch
                resumeSessionData <-
                    sendServerHello12 sparams ctx r ch
                recvClientSecondFlight12 sparams ctx resumeSessionData

    newCertReqContext :: Context -> IO CertReqContext
    newCertReqContext :: Context -> IO CertReqContext
    newCertReqContext Context
    ctx = Context -> Int -> IO CertReqContext
    getStateRNG Context
    ctx Int
    32

    requestCertificateServer :: ServerParams -> Context -> IO Bool
    requestCertificateServer :: ServerParams -> Context -> IO Bool
    requestCertificateServer ServerParams
    sparams Context
    ctx = do
        tls13 <- Context -> IO Bool
    forall (m :: * -> *). MonadIO m => Context -> m Bool
    tls13orLater Context
    ctx
        supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA
        let ok = Bool
    tls13 Bool -> Bool -> Bool
    && Bool
    supportsPHA
        when ok $ do
            certReqCtx <- newCertReqContext ctx
            let certReq = ServerParams -> Context -> CertReqContext -> Bool -> Handshake13
    makeCertRequest ServerParams
    sparams Context
    ctx CertReqContext
    certReqCtx Bool
    False
            bracket (saveHState ctx) (restoreHState ctx) $ \Saved (Maybe HandshakeState)
    _ -> do
                Context -> Handshake13 -> IO ()
    addCertRequest13 Context
    ctx Handshake13
    certReq
                Context -> Packet13 -> IO ()
    sendPacket13 Context
    ctx (Packet13 -> IO ()) -> Packet13 -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    certReq]
        return ok