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