configuration parser for the http backend added

This commit is contained in:
Dennis Frieberg 2020-09-25 11:45:19 +02:00
parent 04d9f063d4
commit df0b72235f
5 changed files with 79 additions and 0 deletions

69
app/Config.hs Normal file
View file

@ -0,0 +1,69 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Config() where
import Toml (TomlCodec, (.=))
import qualified Toml
-- this module should handle everything connected to our TOML config
#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT)
import Data.String
import qualified Network.Wai.Handler.Warp as HTTP
#endif
#ifdef HTTPS_SUPPORT
import qualified Network.Wai.Handler.WarpTLS as HTTPS
#endif
data Configuration = Configuration {
#ifdef HTTP_SUPPORT
httpConf :: [HTTP.Settings]
#endif
#ifdef HTTPS_SUPPORT
httpsConf :: [(HTTP.Settings,HTTPS.TLSSettings)]
#endif
#ifdef FASTCGI_SUPPORT
fastCgiConf :: [FastCgiConfiguration]
#endif
#ifdef CGI_SUPPORT
cgiConf :: [CgiConfiguration]
#endif
}
#ifdef FASTCGI_SUPPORT
data FastCgiConfiguration = FastCgiConfiguration
#endif
#ifdef CGI_SUPPORT
data CgiConfiguration = CgiConfiguration
#endif
#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT)
-- this should not need to exist!!! It is realy ugly crap, but the only we to construct and deconstruct
-- this datatype is via fromString, read, show. And as we want the fromString syntax we want an inverse
-- of it too, but we don't get something nice exposed. Also we don't get the constructors exposed so we
-- pattern match on Strings, this is a hack!!!
httpShowHostPreference :: HTTP.HostPreference -> String
httpShowHostPreference pref = case show pref of
"HostAny" -> "*"
"HostIPv4" -> "*4"
"HostIPv4Only" -> "!4"
"HostIPv6" -> "*6"
"HostIPv6Only" -> "!6"
x -> drop 6 $ init x
-- 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 HTTP.Settings
httpConfigCodec = httpConfigConstructor
<$> Toml.int "Port" .= HTTP.getPort
<*> Toml.string "Bind" .= (httpShowHostPreference . HTTP.getHost)
#endif
configurationCodec :: TomlCodec Configuration
configurationCodec = pure Configuration
#ifdef HTTP_SUPPORT
<*> Toml.list httpConfigCodec "http" .= httpConf
#endif

View file

@ -10,6 +10,7 @@ module Main where
import Control.Concurrent.MVar
import WaiApp
import Control.Concurrent
#ifdef HTTP_SUPPORT
import qualified Network.Wai.Handler.Warp as HTTP
@ -28,6 +29,8 @@ import qualified Network.Wai.Handler.FastCGI as FastCGI
import qualified Network.Wai.Handler.CGI as CGI
#endif
-- we should add support for multiple backends (so we should fork them and
-- then wait till all of them terminated)
main :: IO ()
main = do
serverState <- newMVar newServerState

View file

@ -50,6 +50,7 @@ dependencies:
- wai
- wai-websockets
- http-types
- tomland
when:
- condition: flag(http)

View file

@ -47,6 +47,9 @@ extra-deps:
# Override default flag values for local packages and extra-deps
# flags: {}
flags:
tickLeisteServer:
http: true
# Extra package databases containing global packages
# extra-package-dbs: []

View file

@ -46,6 +46,7 @@ flag https
executable tickLeisteServer
main-is: Main.hs
other-modules:
Config
WaiApp
WebSocketApp
Paths_tickLeisteServer
@ -63,6 +64,7 @@ executable tickLeisteServer
, text
, tickLeiste
, tickLeiste-aeson
, tomland
, uuid
, wai
, wai-websockets
@ -110,6 +112,7 @@ test-suite tickLeisteServer-test
, tickLeiste
, tickLeiste-aeson
, tickLeisteServer
, tomland
, uuid
, wai
, wai-websockets