{-# LANGUAGE OverloadedStrings #-}

module Network.TLS.Handshake.Server (
    handshakeServer,
    handshakeServerWith,
    requestCertificateServer,
    keyUpdate,
    updateKey,
    KeyUpdateRequest (..),
) where

import Control.Monad.State.Strict
import Data.Maybe

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.Imports
import Network.TLS.Struct

-- 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
    hbs <- Context -> IO [HandshakeR]
recvPacketHandshake Context
ctx
    case hbs of
        HandshakeR
chb : [HandshakeR]
_ -> ServerParams -> Context -> HandshakeR -> IO ()
handshake ServerParams
sparams Context
ctx HandshakeR
chb
        [HandshakeR]
_ -> 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] -> String) -> [Handshake] -> String
forall a b. (a -> b) -> a -> b
$ ([Handshake], [WireBytes]) -> [Handshake]
forall a b. (a, b) -> a
fst (([Handshake], [WireBytes]) -> [Handshake])
-> ([Handshake], [WireBytes]) -> [Handshake]
forall a b. (a -> b) -> a -> b
$ [HandshakeR] -> ([Handshake], [WireBytes])
forall a b. [(a, b)] -> ([a], [b])
unzip [HandshakeR]
hbs) (String -> Maybe String
forall a. a -> Maybe a
Just String
"client hello")

handshakeServerWith
    :: ServerParams -> Context -> HandshakeR -> IO ()
handshakeServerWith :: ServerParams -> Context -> HandshakeR -> IO ()
handshakeServerWith = ServerParams -> Context -> HandshakeR -> 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 popped from the recv layer to inspect the packet.
--
-- When the function returns, a new handshake has been successfully negotiated.
-- On any error, a HandshakeFailed exception is raised.
handshake :: ServerParams -> Context -> HandshakeR -> IO ()
handshake :: ServerParams -> Context -> HandshakeR -> IO ()
handshake ServerParams
sparams Context
ctx chb :: HandshakeR
chb@(ClientHello ClientHello
ch, WireBytes
bs) = do
    (chosenVersion, chI, mcrnd) <- ServerParams
-> Context
-> ClientHello
-> WireBytes
-> IO (Version, ClientHello, Maybe ClientRandom)
processClientHello ServerParams
sparams Context
ctx ClientHello
ch WireBytes
bs
    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.
            -- r0 :: Cipher, Hash, Bool
            (keyShareResult, r0, r1) <-
                processClientHello13 sparams ctx chI
            case keyShareResult of
                SelectKeyShareResult
SelectKeyShareNotFound ->
                    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
"no group in common with the client for HRR" AlertDescription
HandshakeFailure
                SelectKeyShareHRR Group
g -> do
                    Context
-> Group -> (Cipher, Hash, Bool) -> ClientHello -> Bool -> IO ()
forall c.
Context
-> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()
sendHRR Context
ctx Group
g (Cipher, Hash, Bool)
r0 ClientHello
chI (Bool -> IO ()) -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe ClientRandom -> Bool
forall a. Maybe a -> Bool
isJust Maybe ClientRandom
mcrnd
                    -- Don't reset ctxEstablished since 0-RTT data
                    -- would be coming, which should be ignored.
                    ServerParams -> Context -> IO ()
handshakeServer ServerParams
sparams Context
ctx
                SelectKeyShareFound KeyShareEntry
cliKeyShare -> do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyShareEntry -> Bool
checkClientKeyShareKeyLength KeyShareEntry
cliKeyShare) (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
"broken key_share" AlertDescription
IllegalParameter
                    -- r2 :: ( SecretTriple ApplicationSecret
                    --       , ClientTrafficSecret HandshakeSecret
                    --       , Bool  -- authenticated
                    --       , Bool) -- rtt0OK
                    r2 <-
                        ServerParams
-> Context
-> KeyShareEntry
-> (Cipher, Hash, Bool)
-> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)
-> ClientHello
-> Maybe ClientRandom
-> IO
     (SecretTriple ApplicationSecret,
      ClientTrafficSecret HandshakeSecret, Bool, Bool)
sendServerHello13 ServerParams
sparams Context
ctx KeyShareEntry
cliKeyShare (Cipher, Hash, Bool)
r0 (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)
r1 ClientHello
chI Maybe ClientRandom
mcrnd
                    recvClientSecondFlight13 sparams ctx r2 chI
        else do
            r <-
                processClientHello12 sparams ctx chI
            updateTranscriptHash12 ctx chb
            resumeSessionData <-
                sendServerHello12 sparams ctx r chI
            recvClientSecondFlight12 sparams ctx resumeSessionData
handshake ServerParams
_ Context
_ HandshakeR
_ = 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
"client Hello is expected" AlertDescription
HandshakeFailure