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

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

    -- * Internal
    runIO,
    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
settings@Settings{Int
HostName -> IO ()
settingsConnectionWindowSize :: Int
settingsStreamWindowSize :: Int
settingsConcurrentStreams :: Int
settingsNumberOfWorkers :: Int
settingsKeyLogger :: HostName -> IO ()
settingsReadBufferLowerLimit :: Int
settingsReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingsStreamWindowSize :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsNumberOfWorkers :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsReadBufferLowerLimit :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsTimeout :: Settings -> Int
..} Credentials
creds HostName
host PortNumber
port ByteString
alpn Manager -> IOBackend -> IO a
action =
    forall a.
Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServer Int
settingsTimeout (forall a. a -> Maybe a
Just HostName
host) (forall a. Show a => a -> HostName
show PortNumber
port) 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
        forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
E.bracket (forall (m :: * -> *) backend params.
(MonadIO m, HasBackend backend, TLSParams params) =>
backend -> params -> m Context
contextNew Backend
backend ServerParams
params) forall (m :: * -> *). MonadIO m => Context -> m ()
bye forall a b. (a -> b) -> a -> b
$ \Context
ctx -> do
            forall (m :: * -> *). MonadIO m => Context -> m ()
handshake Context
ctx
            IOBackend
iobackend <- Handle -> Settings -> IOBackend -> IOBackend
timeoutIOBackend Handle
th Settings
settings 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 = Credentials -> ByteString -> (HostName -> IO ()) -> ServerParams
getServerParams Credentials
creds ByteString
alpn HostName -> IO ()
settingsKeyLogger

-- | 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 =
    forall a.
Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
runTLS Settings
settings Credentials
creds HostName
host PortNumber
port ByteString
"h2" 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
HostName -> IO ()
settingsConnectionWindowSize :: Int
settingsStreamWindowSize :: Int
settingsConcurrentStreams :: Int
settingsNumberOfWorkers :: Int
settingsKeyLogger :: HostName -> IO ()
settingsReadBufferLowerLimit :: Int
settingsReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingsStreamWindowSize :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsNumberOfWorkers :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsReadBufferLowerLimit :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsTimeout :: Settings -> Int
..} HostName
host PortNumber
port Server
server =
    forall a.
Int -> Maybe HostName -> HostName -> TimeoutServer a -> IO a
runTCPServer Int
settingsTimeout (forall a. a -> Maybe a
Just HostName
host) (forall a. Show a => a -> HostName
show PortNumber
port) 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
HostName -> IO ()
settingsConnectionWindowSize :: Int
settingsStreamWindowSize :: Int
settingsConcurrentStreams :: Int
settingsNumberOfWorkers :: Int
settingsKeyLogger :: HostName -> IO ()
settingsReadBufferLowerLimit :: Int
settingsReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingsStreamWindowSize :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsNumberOfWorkers :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsReadBufferLowerLimit :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsTimeout :: Settings -> Int
..} Server
server Manager
mgr IOBackend{IO ByteString
SockAddr
[ByteString] -> IO ()
ByteString -> IO ()
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
recv :: IO ByteString
sendMany :: [ByteString] -> IO ()
send :: ByteString -> IO ()
peerSockAddr :: IOBackend -> SockAddr
mySockAddr :: IOBackend -> SockAddr
recv :: IOBackend -> IO ByteString
sendMany :: IOBackend -> [ByteString] -> IO ()
send :: IOBackend -> ByteString -> 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 :: Int
numberOfWorkers = Int
settingsNumberOfWorkers
            , connectionWindowSize :: Int
connectionWindowSize = Int
settingsConnectionWindowSize
            , settings :: Settings
settings =
                (ServerConfig -> Settings
settings ServerConfig
defaultServerConfig)
                    { initialWindowSize :: Int
initialWindowSize = Int
settingsStreamWindowSize
                    , maxConcurrentStreams :: Maybe Int
maxConcurrentStreams = forall a. a -> Maybe a
Just Int
settingsConcurrentStreams
                    }
            }

runIO
    :: Settings
    -> Credentials
    -> HostName
    -> PortNumber
    -> (ServerIO -> IO (IO ()))
    -> IO ()
runIO :: Settings
-> Credentials
-> HostName
-> PortNumber
-> (ServerIO -> IO (IO ()))
-> IO ()
runIO settings0 :: Settings
settings0@Settings{Int
HostName -> IO ()
settingsConnectionWindowSize :: Int
settingsStreamWindowSize :: Int
settingsConcurrentStreams :: Int
settingsNumberOfWorkers :: Int
settingsKeyLogger :: HostName -> IO ()
settingsReadBufferLowerLimit :: Int
settingsReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingsStreamWindowSize :: Settings -> Int
settingsConnectionWindowSize :: Settings -> Int
settingsConcurrentStreams :: Settings -> Int
settingsNumberOfWorkers :: Settings -> Int
settingsKeyLogger :: Settings -> HostName -> IO ()
settingsReadBufferLowerLimit :: Settings -> Int
settingsReadBufferSize :: Settings -> Int
settingsSlowlorisSize :: Settings -> Int
settingsSendBufferSize :: Settings -> Int
settingsTimeout :: Settings -> Int
..} Credentials
creds HostName
host PortNumber
port ServerIO -> IO (IO ())
action =
    forall a.
Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (Manager -> IOBackend -> IO a)
-> IO a
runTLS Settings
settings0 Credentials
creds HostName
host PortNumber
port ByteString
"h2" forall a b. (a -> b) -> a -> b
$ \Manager
mgr IOBackend{IO ByteString
SockAddr
[ByteString] -> IO ()
ByteString -> IO ()
peerSockAddr :: SockAddr
mySockAddr :: SockAddr
recv :: IO ByteString
sendMany :: [ByteString] -> IO ()
send :: ByteString -> IO ()
peerSockAddr :: IOBackend -> SockAddr
mySockAddr :: IOBackend -> SockAddr
recv :: IOBackend -> IO ByteString
sendMany :: IOBackend -> [ByteString] -> IO ()
send :: IOBackend -> ByteString -> IO ()
..} -> do
        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 :: Int
numberOfWorkers = Int
settingsNumberOfWorkers
            , connectionWindowSize :: Int
connectionWindowSize = Int
settingsConnectionWindowSize
            , settings :: Settings
settings =
                (ServerConfig -> Settings
settings ServerConfig
defaultServerConfig)
                    { initialWindowSize :: Int
initialWindowSize = Int
settingsStreamWindowSize
                    , maxConcurrentStreams :: Maybe Int
maxConcurrentStreams = forall a. a -> Maybe a
Just Int
settingsConcurrentStreams
                    }
            }

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

getServerParams
    :: Credentials
    -> ByteString
    -> (String -> IO ())
    -> ServerParams
getServerParams :: Credentials -> ByteString -> (HostName -> IO ()) -> ServerParams
getServerParams Credentials
creds ByteString
alpn HostName -> IO ()
keyLogger =
    forall a. Default a => a
def
        { serverSupported :: Supported
serverSupported = Supported
supported
        , serverShared :: Shared
serverShared = Shared
shared
        , serverHooks :: ServerHooks
serverHooks = ServerHooks
hooks
        , serverDebug :: DebugParams
serverDebug = DebugParams
debug
        }
  where
    shared :: Shared
shared =
        forall a. Default a => a
def
            { sharedCredentials :: Credentials
sharedCredentials = Credentials
creds
            --            , sharedSessionManager = undefined
            }
    supported :: Supported
supported = Supported
strongSupported
    hooks :: ServerHooks
hooks =
        forall a. Default a => a
def
            { onALPNClientSuggest :: Maybe ([ByteString] -> IO ByteString)
onALPNClientSuggest = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> IO ByteString
selectALPN ByteString
alpn
            }
    debug :: DebugParams
debug =
        forall a. Default a => a
def
            { debugKeyLogger :: HostName -> IO ()
debugKeyLogger = HostName -> IO ()
keyLogger
            }

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