diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..3a24533 --- /dev/null +++ b/app/Config.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs index 00c8593..5966cfa 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/package.yaml b/package.yaml index 3385bde..52fc8a4 100644 --- a/package.yaml +++ b/package.yaml @@ -50,6 +50,7 @@ dependencies: - wai - wai-websockets - http-types +- tomland when: - condition: flag(http) diff --git a/stack.yaml b/stack.yaml index 860c91f..194cec8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 22b02d7..708ca4d 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -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