{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.TLS.Server (
run,
runH2C,
Server,
HostName,
PortNumber,
runTLS,
Settings,
defaultSettings,
settingsTimeout,
settingsSendBufferSize,
settingsSlowlorisSize,
settingReadBufferSize,
settingReadBufferLowerLimit,
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
runTLS
:: Settings
-> Credentials
-> HostName
-> PortNumber
-> ByteString
-> (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
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
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
}
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
""