{-# 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
    [Handshake]
hss <- Context -> IO [Handshake]
recvPacketHandshake Context
ctx
    case [Handshake]
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
    (Version
chosenVersion, CH
ch) <- ServerParams -> Context -> Handshake -> IO (Version, CH)
processClientHello ServerParams
sparams Context
ctx Handshake
clientHello
    if Version
chosenVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
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.
            (Maybe KeyShareEntry
mClientKeyShare, (Cipher, Hash, Bool)
r0) <-
                ServerParams
-> Context -> CH -> IO (Maybe KeyShareEntry, (Cipher, Hash, Bool))
processClientHello13 ServerParams
sparams Context
ctx CH
ch
            case Maybe KeyShareEntry
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
                    (SecretTriple ApplicationSecret,
 ClientTrafficSecret HandshakeSecret, Bool, Bool)
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
                    ServerParams
-> Context
-> (SecretTriple ApplicationSecret,
    ClientTrafficSecret HandshakeSecret, Bool, Bool)
-> CH
-> IO ()
recvClientSecondFlight13 ServerParams
sparams Context
ctx (SecretTriple ApplicationSecret,
 ClientTrafficSecret HandshakeSecret, Bool, Bool)
r1 CH
ch
        else do
            (Cipher, Maybe Credential)
r <-
                ServerParams -> Context -> CH -> IO (Cipher, Maybe Credential)
processClinetHello12 ServerParams
sparams Context
ctx CH
ch
            Maybe SessionData
resumeSessionData <-
                ServerParams
-> Context
-> (Cipher, Maybe Credential)
-> CH
-> IO (Maybe SessionData)
sendServerHello12 ServerParams
sparams Context
ctx (Cipher, Maybe Credential)
r CH
ch
            ServerParams -> Context -> Maybe SessionData -> IO ()
recvClientSecondFlight12 ServerParams
sparams Context
ctx Maybe SessionData
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
    Bool
tls13 <- Context -> IO Bool
forall (m :: * -> *). MonadIO m => Context -> m Bool
tls13orLater Context
ctx
    Bool
supportsPHA <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getClientSupportsPHA
    let ok :: Bool
ok = Bool
tls13 Bool -> Bool -> Bool
&& Bool
supportsPHA
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        CertReqContext
certReqCtx <- Context -> IO CertReqContext
newCertReqContext Context
ctx
        let certReq :: Handshake13
certReq = ServerParams -> Context -> CertReqContext -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx CertReqContext
certReqCtx
        IO (Saved (Maybe HandshakeState))
-> (Saved (Maybe HandshakeState)
    -> IO (Saved (Maybe HandshakeState)))
-> (Saved (Maybe HandshakeState) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Context -> IO (Saved (Maybe HandshakeState))
saveHState Context
ctx) (Context
-> Saved (Maybe HandshakeState)
-> IO (Saved (Maybe HandshakeState))
restoreHState Context
ctx) ((Saved (Maybe HandshakeState) -> IO ()) -> IO ())
-> (Saved (Maybe HandshakeState) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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]
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok