90 lines
2.7 KiB
Haskell
90 lines
2.7 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
#ifndef HTTP_SUPPORT
|
|
module Backend.Http
|
|
where
|
|
|
|
|
|
#else
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
-- we export a bit more than we have to, because the https module can reuse these things.
|
|
module Backend.Http
|
|
( HttpConfiguration (..),
|
|
httpDefaultSettings,
|
|
httpDefaultSetting,
|
|
forkHttpBackend, -- key export
|
|
httpConfigCodec,
|
|
httpConfigsCodec,
|
|
httpToWarpConfig,
|
|
)
|
|
where
|
|
|
|
import qualified Config as Toml (configM,ConfigM)
|
|
import Config hiding (configM,ConfigM)
|
|
import Control.Concurrent.MVar(MVar)
|
|
import Data.String
|
|
import qualified Data.Text as T
|
|
import qualified Network.Wai as Wai
|
|
import qualified Network.Wai.Handler.Warp as HTTP
|
|
import Toml (TomlCodec, (.=))
|
|
import qualified Toml
|
|
import Data.Semigroup (getFirst, First(..))
|
|
import Data.Maybe(fromJust)
|
|
import Data.Coerce
|
|
import Environment
|
|
import Control.Monad.IO.Class
|
|
|
|
type BindPreference = String
|
|
|
|
_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue
|
|
_BindPreference = Toml._String
|
|
|
|
bindPreference :: Toml.Key -> TomlCodec BindPreference
|
|
bindPreference = Toml.match _BindPreference
|
|
|
|
data HttpConfiguration = HttpConfiguration
|
|
{ instanceName :: Toml.ConfigM T.Text,
|
|
port :: Toml.ConfigM Int,
|
|
bindPref :: Toml.ConfigM BindPreference
|
|
} deriving (Show)
|
|
|
|
instance Monoid HttpConfiguration where
|
|
mempty = HttpConfiguration mempty mempty mempty
|
|
|
|
instance Semigroup HttpConfiguration where
|
|
a <> b = HttpConfiguration {
|
|
instanceName = instanceName a <> instanceName b,
|
|
port = port a <> port b,
|
|
bindPref = bindPref a <> bindPref b
|
|
}
|
|
|
|
httpDefaultSetting :: HttpConfiguration
|
|
httpDefaultSetting = HttpConfiguration (setConfigM ("http" :: T.Text)) (setConfigM (80 :: Int)) (setConfigM ("*" :: BindPreference))
|
|
|
|
httpDefaultSettings :: [HttpConfiguration]
|
|
httpDefaultSettings = [httpDefaultSetting]
|
|
|
|
httpConfigCodec :: TomlCodec HttpConfiguration
|
|
httpConfigCodec =
|
|
HttpConfiguration
|
|
<$> Toml.configM Toml.text "instanceName" .= instanceName
|
|
<*> Toml.configM Toml.int "port" .= port
|
|
<*> Toml.configM bindPreference "bind" .= bindPref
|
|
|
|
httpConfigsCodec :: TomlCodec [HttpConfiguration]
|
|
httpConfigsCodec = Toml.list httpConfigCodec "http"
|
|
|
|
forkHttpBackend :: Wai.Application -> FilePath -> EnvM [MVar ()]
|
|
forkHttpBackend app = forkWithConfigs (backend app) httpConfigsCodec
|
|
|
|
httpToWarpConfig :: HttpConfiguration -> HTTP.Settings
|
|
httpToWarpConfig config' = HTTP.setPort confPort $ HTTP.setHost (fromString confBindPref) HTTP.defaultSettings
|
|
where
|
|
config = config' <> httpDefaultSetting
|
|
confPort = getConfigM $ port config
|
|
confBindPref = getConfigM $ bindPref config
|
|
|
|
|
|
backend :: Wai.Application -> HttpConfiguration -> EnvM ()
|
|
backend app config = liftIO $ HTTP.runSettings (httpToWarpConfig config) app
|
|
#endif
|