{-# 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
import Network.TLS.Types

-- 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
                    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 <-
                processClinetHello12 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 -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx CertReqContext
certReqCtx
        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