Splittertech/tickLeisteServer
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

redone backend handling and config parsing

Browse source
This commit is contained in:
Dennis Frieberg 2021-03-18 15:31:59 +01:00
parent 4733c3e3e2
commit c4a1a442f3
9 changed files with 177 additions and 166 deletions
Download patch file Download diff file Expand all files Collapse all files

43
app/Backend/Http.hs
View file

@ -5,21 +5,25 @@ module Backend.Http
( HttpConfiguration (..),
httpDefaultSettings,
httpDefaultSetting,
forkHttpBackend,
forkHttpBackend, -- key export
httpConfigCodec,
httpConfigsCodec,
httpToWarpConfig,
)
where
import Config
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 Network.Wai.Handler.Warp as HTTP
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
type BindPreference = String
@ -30,13 +34,23 @@ bindPreference :: Toml.Key -> TomlCodec BindPreference
bindPreference = Toml.match _BindPreference
data HttpConfiguration = HttpConfiguration
{ instanceName :: T.Text,
port :: Int,
bindPref :: BindPreference
{ 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 "http" 80 "*"
httpDefaultSetting = HttpConfiguration (setConfigM ("http" :: T.Text)) (setConfigM (80 :: Int)) (setConfigM ("*" :: BindPreference))
httpDefaultSettings :: [HttpConfiguration]
httpDefaultSettings = [httpDefaultSetting]
@ -44,9 +58,9 @@ httpDefaultSettings = [httpDefaultSetting]
httpConfigCodec :: TomlCodec HttpConfiguration
httpConfigCodec =
HttpConfiguration
<$> Toml.text "InstanceName" .= instanceName
<*> Toml.int "Port" .= port
<*> bindPreference "Bind" .= bindPref
<$> 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"
@ -55,7 +69,12 @@ 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
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 -> IO ()
backend app config = HTTP.runSettings (httpToWarpConfig config) $ app
backend app config = HTTP.runSettings (httpToWarpConfig config) app