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

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

    -- * Settings
    Settings,
    defaultSettings,
    settingsTimeout,
    settingsSendBufferSize,
    settingsSlowlorisSize,
    settingReadBufferSize,
    settingReadBufferLowerLimit,

    -- * IO backend
    IOBackend,
    send,
    sendMany,
    recv,
) where

import Data.ByteString (ByteString)
import Data.Default.Class (def)
import Network.HTTP2.Server (Server)
import qualified Network.HTTP2.Server as H2Server
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.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
settingReadBufferLowerLimit :: Int
settingReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingReadBufferLowerLimit :: Settings -> Int
settingReadBufferSize :: 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
            let iobackend :: IOBackend
iobackend = Handle -> Settings -> IOBackend -> IOBackend
timeoutIOBackend Handle
th Settings
settings forall a b. (a -> b) -> a -> b
$ Context -> IOBackend
tlsIOBackend Context
ctx
            Manager -> IOBackend -> IO a
action Manager
mgr IOBackend
iobackend
  where
    params :: ServerParams
params = Credentials -> ByteString -> ServerParams
getServerParams 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 =
    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
settingReadBufferLowerLimit :: Int
settingReadBufferSize :: Int
settingsSlowlorisSize :: Int
settingsSendBufferSize :: Int
settingsTimeout :: Int
settingReadBufferLowerLimit :: Settings -> Int
settingReadBufferSize :: 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' Settings
settings Server
server Manager
mgr IOBackend{IO ByteString
[ByteString] -> IO ()
ByteString -> IO ()
recv :: IO ByteString
sendMany :: [ByteString] -> IO ()
send :: ByteString -> IO ()
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 -> IO Config
allocConfigForServer Settings
settings Manager
mgr ByteString -> IO ()
send IO ByteString
recv)
        Config -> IO ()
freeConfigForServer
        (\Config
conf -> Config -> Server -> IO ()
H2Server.run Config
conf Server
server)

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

getServerParams
    :: Credentials
    -> ByteString
    -> ServerParams
getServerParams :: Credentials -> ByteString -> ServerParams
getServerParams Credentials
creds ByteString
alpn =
    forall a. Default a => a
def
        { serverSupported :: Supported
serverSupported = Supported
supported
        , serverShared :: Shared
serverShared = Shared
shared
        , serverHooks :: ServerHooks
serverHooks = ServerHooks
hooks
        }
  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
            }

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
""