{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.HTTP2.TLS.Server (
    -- * Runners
    run,
    runH2C,
    Server,
    HostName,
    PortNumber,
    runTLS,

    -- * Settings
    Settings,
    defaultSettings,
    settingsTimeout,
    settingsSendBufferSize,
    settingsSlowlorisSize,
    settingsReadBufferSize,
    settingsReadBufferLowerLimit,
    settingsKeyLogger,
    settingsNumberOfWorkers,
    settingsConcurrentStreams,
    settingsConnectionWindowSize,
    settingsStreamWindowSize,
    settingsSessionManager,
    settingsOpenServerSocket,
    settingsEarlyDataSize,

    -- * IO backend
    IOBackend,
    send,
    sendMany,
    recv,
    mySockAddr,
    peerSockAddr,

    -- * Internal
    runIO,
    runIOH2C,
    Stream,
    ServerIO (..),
) where

import Data.ByteString (ByteString)
import Data.Default.Class (def)
import Network.HTTP2.Server (
    Server,
    connectionWindowSize,
    defaultServerConfig,
    initialWindowSize,
    maxConcurrentStreams,
    numberOfWorkers,
    settings,
 )
import qualified Network.HTTP2.Server as H2Server
import Network.HTTP2.Server.Internal (ServerIO, Stream)
import qualified Network.HTTP2.Server.Internal as H2I
import Network.Run.TCP.Timeout
import Network.Socket (
    HostName,
    PortNumber,
 )
import Network.TLS hiding (HostName)
import qualified System.TimeManager as T
import qualified UnliftIO.Exception as E

import Network.HTTP2.TLS.Config
import Network.HTTP2.TLS.IO
import Network.HTTP2.TLS.Server.Settings
import Network.HTTP2.TLS.Supported

-- | Running a TLS client.
--   'IOBackend' provides sending and receiving functions
--   with timeout based on 'Settings'.
runTLS
    :: Settings
    -> Credentials
    -> HostName
    -> PortNumber
    -> ByteString
    -- ^ ALPN
    -> (T.Manager -> IOBackend -> IO a)
    -> IO a
runTLS :: forall a.
Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
runTLS Settings
settings Credentials
creds HostName
host PortNumber
port ByteString
alpn Manager -> IOBackend -> IO a
action =
    (AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
forall a.
(AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServerWithSocket
        (Settings -> AddrInfo -> IO Socket
settingsOpenServerSocket Settings
settings)
        (Settings -> Int
settingsTimeout Settings
settings)
        (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host)
        (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port)
        (TimeoutServer a -> IO a) -> TimeoutServer a -> IO a
forall a b. (a -> b) -> a -> b
$ \Manager
mgr Handle
th Socket
sock -> do
            Backend
backend <- Settings -> Socket -> IO Backend
mkBackend Settings
settings Socket
sock
            IO Context -> (Context -> IO ()) -> (Context -> IO a) -> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (Backend -> ServerParams -> IO Context
forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Backend
backend ServerParams
params) Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
bye ((Context -> IO a) -> IO a) -> (Context -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
                Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx
                IOBackend
iobackend <- Handle -> Settings -> IOBackend -> IOBackend
timeoutIOBackend Handle
th Settings
settings (IOBackend -> IOBackend) -> IO IOBackend -> IO IOBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Socket -> IO IOBackend
tlsIOBackend Context
ctx Socket
sock
                Manager -> IOBackend -> IO a
action Manager
mgr IOBackend
iobackend
  where
    params :: ServerParams
params = Settings -> Credentials -> ByteString -> ServerParams
getServerParams Settings
settings Credentials
creds ByteString
alpn

-- | Running an HTTP\/2 client over TLS (over TCP).
--   ALPN is "h2".
run :: Settings -> Credentials -> HostName -> PortNumber -> Server -> IO ()
run :: Settings
-> Credentials -> HostName -> PortNumber -> Server -> IO ()
run Settings
settings Credentials
creds HostName
host PortNumber
port Server
server =
    Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO ())
-> IO ()
forall a.
Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
runTLS Settings
settings Credentials
creds HostName
host PortNumber
port ByteString
"h2" ((Manager -> IOBackend -> IO ()) -> IO ())
-> (Manager -> IOBackend -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Settings -> Server -> Manager -> IOBackend -> IO ()
run' Settings
settings Server
server

-- | Running an HTTP\/2 client over TCP.
runH2C :: Settings -> HostName -> PortNumber -> Server -> IO ()
runH2C :: Settings -> HostName -> PortNumber -> Server -> IO ()
runH2C settings :: Settings
settings@Settings{Int
SessionManager
HostName -> IO ()
AddrInfo -> IO Socket
settingsTimeout :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsReadBufferLowerLimit :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsNumberOfWorkers :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsSessionManager :: Settings -> SessionManager
settingsOpenServerSocket :: Settings -> AddrInfo -> IO Socket
settingsEarlyDataSize :: Settings -> Int
settingsTimeout :: Int
settingsSendBufferSize :: Int
settingsSlowlorisSize :: Int
settingsReadBufferSize :: Int
settingsReadBufferLowerLimit :: Int
settingsKeyLogger :: HostName -> IO ()
settingsNumberOfWorkers :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsOpenServerSocket :: AddrInfo -> IO Socket
settingsEarlyDataSize :: Int
..} HostName
host PortNumber
port Server
server =
    (AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer () -> IO ()
forall a.
(AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServerWithSocket
        AddrInfo -> IO Socket
settingsOpenServerSocket
        Int
settingsTimeout
        (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host)
        (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port)
        (TimeoutServer () -> IO ()) -> TimeoutServer () -> IO ()
forall a b. (a -> b) -> a -> b
$ \Manager
mgr Handle
th Socket
sock -> do
            IOBackend
iobackend0 <- Settings -> Socket -> IO IOBackend
tcpIOBackend Settings
settings Socket
sock
            let iobackend :: IOBackend
iobackend = Handle -> Settings -> IOBackend -> IOBackend
timeoutIOBackend Handle
th Settings
settings IOBackend
iobackend0
            Settings -> Server -> Manager -> IOBackend -> IO ()
run' Settings
settings Server
server Manager
mgr IOBackend
iobackend

run' :: Settings -> Server -> T.Manager -> IOBackend -> IO ()
run' :: Settings -> Server -> Manager -> IOBackend -> IO ()
run' settings0 :: Settings
settings0@Settings{Int
SessionManager
HostName -> IO ()
AddrInfo -> IO Socket
settingsTimeout :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsReadBufferLowerLimit :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsNumberOfWorkers :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsSessionManager :: Settings -> SessionManager
settingsOpenServerSocket :: Settings -> AddrInfo -> IO Socket
settingsEarlyDataSize :: Settings -> Int
settingsTimeout :: Int
settingsSendBufferSize :: Int
settingsSlowlorisSize :: Int
settingsReadBufferSize :: Int
settingsReadBufferLowerLimit :: Int
settingsKeyLogger :: HostName -> IO ()
settingsNumberOfWorkers :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsOpenServerSocket :: AddrInfo -> IO Socket
settingsEarlyDataSize :: Int
..} Server
server Manager
mgr IOBackend{IO ByteString
SockAddr
[ByteString] -> IO ()
ByteString -> IO ()
send :: IOBackend -> ByteString -> IO ()
sendMany :: IOBackend -> [ByteString] -> IO ()
recv :: IOBackend -> IO ByteString
mySockAddr :: IOBackend -> SockAddr
peerSockAddr :: IOBackend -> SockAddr
send :: ByteString -> IO ()
sendMany :: [ByteString] -> IO ()
recv :: IO ByteString
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
..} =
    IO Config -> (Config -> IO ()) -> (Config -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket
        (Settings
-> Manager
-> (ByteString -> IO ())
-> IO ByteString
-> SockAddr
-> SockAddr
-> IO Config
allocConfigForServer Settings
settings0 Manager
mgr ByteString -> IO ()
send IO ByteString
recv SockAddr
mySockAddr SockAddr
peerSockAddr)
        Config -> IO ()
freeConfigForServer
        (\Config
conf -> ServerConfig -> Config -> Server -> IO ()
H2Server.run ServerConfig
sconf Config
conf Server
server)
  where
    sconf :: ServerConfig
sconf =
        ServerConfig
defaultServerConfig
            { numberOfWorkers = settingsNumberOfWorkers
            , connectionWindowSize = settingsConnectionWindowSize
            , settings =
                (settings defaultServerConfig)
                    { initialWindowSize = settingsStreamWindowSize
                    , maxConcurrentStreams = Just settingsConcurrentStreams
                    }
            }

runIO
    :: Settings
    -> Credentials
    -> HostName
    -> PortNumber
    -> (ServerIO -> IO (IO ()))
    -> IO ()
runIO :: Settings
-> Credentials
-> HostName
-> PortNumber
-> (ServerIO -> IO (IO ()))
-> IO ()
runIO Settings
settings Credentials
creds HostName
host PortNumber
port ServerIO -> IO (IO ())
action =
    Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO ())
-> IO ()
forall a.
Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
runTLS Settings
settings Credentials
creds HostName
host PortNumber
port ByteString
"h2" ((Manager -> IOBackend -> IO ()) -> IO ())
-> (Manager -> IOBackend -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Manager
mgr IOBackend
iobackend ->
        Settings
-> (ServerIO -> IO (IO ())) -> Manager -> IOBackend -> IO ()
runIO' Settings
settings ServerIO -> IO (IO ())
action Manager
mgr IOBackend
iobackend

runIO'
    :: Settings -> (ServerIO -> IO (IO ())) -> T.Manager -> IOBackend -> IO ()
runIO' :: Settings
-> (ServerIO -> IO (IO ())) -> Manager -> IOBackend -> IO ()
runIO' settings0 :: Settings
settings0@Settings{Int
SessionManager
HostName -> IO ()
AddrInfo -> IO Socket
settingsTimeout :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsReadBufferLowerLimit :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsNumberOfWorkers :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsSessionManager :: Settings -> SessionManager
settingsOpenServerSocket :: Settings -> AddrInfo -> IO Socket
settingsEarlyDataSize :: Settings -> Int
settingsTimeout :: Int
settingsSendBufferSize :: Int
settingsSlowlorisSize :: Int
settingsReadBufferSize :: Int
settingsReadBufferLowerLimit :: Int
settingsKeyLogger :: HostName -> IO ()
settingsNumberOfWorkers :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsOpenServerSocket :: AddrInfo -> IO Socket
settingsEarlyDataSize :: Int
..} ServerIO -> IO (IO ())
action Manager
mgr IOBackend{IO ByteString
SockAddr
[ByteString] -> IO ()
ByteString -> IO ()
send :: IOBackend -> ByteString -> IO ()
sendMany :: IOBackend -> [ByteString] -> IO ()
recv :: IOBackend -> IO ByteString
mySockAddr :: IOBackend -> SockAddr
peerSockAddr :: IOBackend -> SockAddr
send :: ByteString -> IO ()
sendMany :: [ByteString] -> IO ()
recv :: IO ByteString
mySockAddr :: SockAddr
peerSockAddr :: SockAddr
..} =
    IO Config -> (Config -> IO ()) -> (Config -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket
        (Settings
-> Manager
-> (ByteString -> IO ())
-> IO ByteString
-> SockAddr
-> SockAddr
-> IO Config
allocConfigForServer Settings
settings0 Manager
mgr ByteString -> IO ()
send IO ByteString
recv SockAddr
mySockAddr SockAddr
peerSockAddr)
        Config -> IO ()
freeConfigForServer
        (\Config
conf -> ServerConfig -> Config -> (ServerIO -> IO (IO ())) -> IO ()
H2I.runIO ServerConfig
sconf Config
conf ServerIO -> IO (IO ())
action)
  where
    sconf :: ServerConfig
sconf =
        ServerConfig
defaultServerConfig
            { numberOfWorkers = settingsNumberOfWorkers
            , connectionWindowSize = settingsConnectionWindowSize
            , settings =
                (settings defaultServerConfig)
                    { initialWindowSize = settingsStreamWindowSize
                    , maxConcurrentStreams = Just settingsConcurrentStreams
                    }
            }

runIOH2C
    :: Settings -> HostName -> PortNumber -> (ServerIO -> IO (IO ())) -> IO ()
runIOH2C :: Settings
-> HostName -> PortNumber -> (ServerIO -> IO (IO ())) -> IO ()
runIOH2C settings0 :: Settings
settings0@Settings{Int
SessionManager
HostName -> IO ()
AddrInfo -> IO Socket
settingsTimeout :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsReadBufferLowerLimit :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsNumberOfWorkers :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsSessionManager :: Settings -> SessionManager
settingsOpenServerSocket :: Settings -> AddrInfo -> IO Socket
settingsEarlyDataSize :: Settings -> Int
settingsTimeout :: Int
settingsSendBufferSize :: Int
settingsSlowlorisSize :: Int
settingsReadBufferSize :: Int
settingsReadBufferLowerLimit :: Int
settingsKeyLogger :: HostName -> IO ()
settingsNumberOfWorkers :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsOpenServerSocket :: AddrInfo -> IO Socket
settingsEarlyDataSize :: Int
..} HostName
host PortNumber
port ServerIO -> IO (IO ())
action =
    (AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer () -> IO ()
forall a.
(AddrInfo -> IO Socket)
-> Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServerWithSocket
        AddrInfo -> IO Socket
settingsOpenServerSocket
        Int
settingsTimeout
        (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host)
        (PortNumber -> HostName
forall a. Show a => a -> HostName
show PortNumber
port)
        (TimeoutServer () -> IO ()) -> TimeoutServer () -> IO ()
forall a b. (a -> b) -> a -> b
$ \Manager
mgr Handle
th Socket
sock -> do
            IOBackend
iobackend0 <- Settings -> Socket -> IO IOBackend
tcpIOBackend Settings
settings0 Socket
sock
            let iobackend :: IOBackend
iobackend = Handle -> Settings -> IOBackend -> IOBackend
timeoutIOBackend Handle
th Settings
settings0 IOBackend
iobackend0
            Settings
-> (ServerIO -> IO (IO ())) -> Manager -> IOBackend -> IO ()
runIO' Settings
settings0 ServerIO -> IO (IO ())
action Manager
mgr IOBackend
iobackend

----------------------------------------------------------------

getServerParams
    :: Settings
    -> Credentials
    -> ByteString
    -> ServerParams
getServerParams :: Settings -> Credentials -> ByteString -> ServerParams
getServerParams Settings{Int
SessionManager
HostName -> IO ()
AddrInfo -> IO Socket
settingsTimeout :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsReadBufferLowerLimit :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsNumberOfWorkers :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsStreamWindowSize :: Settings -> Int
settingsSessionManager :: Settings -> SessionManager
settingsOpenServerSocket :: Settings -> AddrInfo -> IO Socket
settingsEarlyDataSize :: Settings -> Int
settingsTimeout :: Int
settingsSendBufferSize :: Int
settingsSlowlorisSize :: Int
settingsReadBufferSize :: Int
settingsReadBufferLowerLimit :: Int
settingsKeyLogger :: HostName -> IO ()
settingsNumberOfWorkers :: Int
settingsConcurrentStreams :: Int
settingsStreamWindowSize :: Int
settingsConnectionWindowSize :: Int
settingsSessionManager :: SessionManager
settingsOpenServerSocket :: AddrInfo -> IO Socket
settingsEarlyDataSize :: Int
..} Credentials
creds ByteString
alpn =
    ServerParams
forall a. Default a => a
def
        { serverSupported = supported
        , serverShared = shared
        , serverHooks = hooks
        , serverDebug = debug
        , serverEarlyDataSize = settingsEarlyDataSize
        }
  where
    shared :: Shared
shared =
        Shared
forall a. Default a => a
def
            { sharedCredentials = creds
            , sharedSessionManager = settingsSessionManager
            }
    supported :: Supported
supported = Supported
strongSupported
    hooks :: ServerHooks
hooks =
        ServerHooks
forall a. Default a => a
def
            { onALPNClientSuggest = Just $ selectALPN alpn
            }
    debug :: DebugParams
debug =
        DebugParams
forall a. Default a => a
def
            { debugKeyLogger = settingsKeyLogger
            }

selectALPN :: ByteString -> [ByteString] -> IO ByteString
selectALPN :: ByteString -> [ByteString] -> IO ByteString
selectALPN ByteString
key [ByteString]
xs
    | ByteString
key ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
xs = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
key
    | Bool
otherwise = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""