72 lines
2.5 KiB
Haskell
72 lines
2.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Backend.Http
|
|
( HttpConfiguration (..),
|
|
httpDefaultSettings,
|
|
httpDefaultSetting,
|
|
forkHttpBackend,
|
|
httpConfigCodec,
|
|
httpConfigsCodec,
|
|
)
|
|
where
|
|
|
|
import Config
|
|
import Control.Concurrent
|
|
import Control.Concurrent.MVar
|
|
import Data.String
|
|
import qualified Data.Text as T
|
|
import qualified Network.Wai as Wai
|
|
import Network.Wai.Handler.Warp as HTTP
|
|
import Toml (TomlCodec, (.=))
|
|
import qualified Toml
|
|
|
|
-- We leave it as a Text here and defer the conversion to the warp type to the last possible moment.
|
|
-- At least we can touch and print a String. Excepet that we don't use it so we don't need it in another
|
|
-- form
|
|
|
|
-- even though this is just a String alias, we leave the infrastructure in place. Maybe we want to change that
|
|
-- type at some point. Then we can redifne the stuff to work with our new type.
|
|
-- One can think about this as being accidantally a String, and not by design.
|
|
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 :: T.Text,
|
|
port :: Int,
|
|
bindPref :: BindPreference
|
|
}
|
|
|
|
httpDefaultSetting :: HttpConfiguration
|
|
httpDefaultSetting = HttpConfiguration "http" 80 "*"
|
|
|
|
httpDefaultSettings :: [HttpConfiguration]
|
|
httpDefaultSettings = [httpDefaultSetting]
|
|
|
|
-- why a String? Why is the only way to generate a HostPreference by its IsString instance?
|
|
-- why does warp not expose its constructors??
|
|
httpConfigConstructor :: Int -> String -> HTTP.Settings
|
|
httpConfigConstructor port bind = HTTP.setPort port $ HTTP.setHost (fromString bind) HTTP.defaultSettings
|
|
|
|
httpConfigCodec :: TomlCodec HttpConfiguration
|
|
httpConfigCodec =
|
|
HttpConfiguration
|
|
<$> Toml.text "InstanceName" .= instanceName
|
|
<*> Toml.int "Port" .= port
|
|
<*> bindPreference "Bind" .= bindPref
|
|
|
|
httpConfigsCodec :: TomlCodec [HttpConfiguration]
|
|
httpConfigsCodec = Toml.list httpConfigCodec "http"
|
|
|
|
forkHttpBackend :: Wai.Application -> FilePath -> IO [MVar ()]
|
|
forkHttpBackend app configFile = forkWithConfigs (backend app) httpConfigsCodec configFile
|
|
|
|
httpToWarpConfig :: HttpConfiguration -> HTTP.Settings
|
|
httpToWarpConfig config = HTTP.setPort (port config) $ HTTP.setHost (fromString $ bindPref config) $ HTTP.defaultSettings
|
|
|
|
backend :: Wai.Application -> HttpConfiguration -> IO ()
|
|
backend app config = HTTP.runSettings (httpToWarpConfig config) $ app
|