From df0b72235fc94089ea3123295f4e2c9b2786e4fc Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Fri, 25 Sep 2020 11:45:19 +0200 Subject: [PATCH 01/10] configuration parser for the http backend added --- app/Config.hs | 69 ++++++++++++++++++++++++++++++++++++++++++ app/Main.hs | 3 ++ package.yaml | 1 + stack.yaml | 3 ++ tickLeisteServer.cabal | 3 ++ 5 files changed, 79 insertions(+) create mode 100644 app/Config.hs 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 From f03f91f917acfb91607c0222556f16073bbb338c Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sat, 26 Sep 2020 01:00:38 +0200 Subject: [PATCH 02/10] config parser works --- app/Config.hs | 64 ++++++++++++++++++++++++++++++++++++------ package.yaml | 6 ++-- stack.yaml | 3 ++ tickLeisteServer.cabal | 6 ++-- 4 files changed, 65 insertions(+), 14 deletions(-) diff --git a/app/Config.hs b/app/Config.hs index 3a24533..8d7a73a 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Config() where +module Config(Configuration(..),defaultConfiguration,configurationCodec) where import Toml (TomlCodec, (.=)) import qualified Toml +import System.IO -- this module should handle everything connected to our TOML config #if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) @@ -16,17 +16,18 @@ import qualified Network.Wai.Handler.WarpTLS as HTTPS #endif data Configuration = Configuration { + cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor #ifdef HTTP_SUPPORT - httpConf :: [HTTP.Settings] + , httpConf :: [HTTP.Settings] #endif #ifdef HTTPS_SUPPORT - httpsConf :: [(HTTP.Settings,HTTPS.TLSSettings)] + , httpsConf :: [(HTTP.Settings,HTTPS.TLSSettings)] #endif #ifdef FASTCGI_SUPPORT - fastCgiConf :: [FastCgiConfiguration] + , fastCgiConf :: [FastCgiConfiguration] #endif #ifdef CGI_SUPPORT - cgiConf :: [CgiConfiguration] + , cgiConf :: [CgiConfiguration] #endif } @@ -38,8 +39,22 @@ data FastCgiConfiguration = FastCgiConfiguration data CgiConfiguration = CgiConfiguration #endif -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) +defaultConfiguration :: Configuration +defaultConfiguration = Configuration () +#ifdef HTTP_SUPPORT + [HTTP.defaultSettings] +#endif +#ifdef HTTPS_SUPPORT + [(HTTP.defaultSettings,HTTPS.defaultTlsSettings)] +#endif +#ifdef FASTCGI_SUPPORT + [FastCgiConfiguration] +#endif +#ifdef CGI_SUPPORT + [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 @@ -62,8 +77,41 @@ httpConfigCodec = httpConfigConstructor <*> Toml.string "Bind" .= (httpShowHostPreference . HTTP.getHost) #endif +#ifdef HTTPS_SUPPORT +httpsConfigCodec :: TomlCodec (HTTP.Settings,HTTPS.TLSSettings) +httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' + +httpsConfigCodec' :: TomlCodec (HTTPS.TLSSettings) +httpsConfigCodec' = HTTPS.tlsSettingsChain +-- the hardcoded strings are a bloody hack, but we can't extract the values back out of a config (they are there +-- warp just doesn't export the neccesarry types). So we hardcode default values, which is kind of realy bad, but +-- we don't need it in our usecase + <$> Toml.string "Certificate" .= (const "certificate.pem") + <*> Toml.arrayOf Toml._String "CertChain" .= (const []) + <*> Toml.string "KeyFile" .= (const "key.pem") +#endif + +#ifdef FASTCGI_SUPPORT +fastCgiConfigCodec :: TomlCodec FastCgiConfiguration +fastCgiConfigCodec = pure FastCgiConfiguration +#endif + +#ifdef CGI_SUPPORT +cgiConfigCodec :: TomlCodec CgiConfiguration +cgiConfigCodec = pure CgiConfiguration +#endif + configurationCodec :: TomlCodec Configuration -configurationCodec = pure Configuration +configurationCodec = pure (Configuration ()) #ifdef HTTP_SUPPORT <*> Toml.list httpConfigCodec "http" .= httpConf #endif +#ifdef HTTPS_SUPPORT + <*> Toml.list httpsConfigCodec "https" .= httpsConf +#endif +#ifdef FASTCGI_SUPPORT + <*> Toml.list fastCgiConfigCodec "fast-cgi" .= fastCgiConf +#endif +#ifdef CGI_SUPPORT + <*> Toml.list cgiConfigCodec "cgi" .= cgiConf +#endif diff --git a/package.yaml b/package.yaml index 52fc8a4..e0ab188 100644 --- a/package.yaml +++ b/package.yaml @@ -27,15 +27,15 @@ flags: https: description: Build with https support manual: true - default: false + default: true fast-cgi: description: Build with fastcgi support -- this depends on the fcgi c library manual: true - default: false + default: true cgi: description: Build with cgi support manual: true - default: false + default: true dependencies: - base >= 4.7 && < 5 diff --git a/stack.yaml b/stack.yaml index 194cec8..bc4c15f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -50,6 +50,9 @@ extra-deps: flags: tickLeisteServer: http: true + https: true + fast-cgi: true + cgi: true # Extra package databases containing global packages # extra-package-dbs: [] diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 708ca4d..7ea295a 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -26,12 +26,12 @@ source-repository head flag cgi description: Build with cgi support manual: True - default: False + default: True flag fast-cgi description: Build with fastcgi support -- this depends on the fcgi c library manual: True - default: False + default: True flag http description: Build with http support @@ -41,7 +41,7 @@ flag http flag https description: Build with https support manual: True - default: False + default: True executable tickLeisteServer main-is: Main.hs From 0b1e9339e26a66fc8961ffff57dbb9d6a3fdf163 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Thu, 1 Oct 2020 21:57:14 +0200 Subject: [PATCH 03/10] changed to an intermediate config datastructures --- app/Config.hs | 77 ++++++++++++++++++++++++++++++++------------------- 1 file changed, 48 insertions(+), 29 deletions(-) diff --git a/app/Config.hs b/app/Config.hs index 8d7a73a..6b7daf0 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Config(Configuration(..),defaultConfiguration,configurationCodec) where +module Config(Configuration(..),defaultConfiguration,HttpConfiguration (..)) where import Toml (TomlCodec, (.=)) import qualified Toml import System.IO +import qualified Data.Text as T -- this module should handle everything connected to our TOML config #if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) @@ -15,13 +16,13 @@ import qualified Network.Wai.Handler.Warp as HTTP import qualified Network.Wai.Handler.WarpTLS as HTTPS #endif -data Configuration = Configuration { - cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor +data Configuration = Configuration + { cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor #ifdef HTTP_SUPPORT - , httpConf :: [HTTP.Settings] + , httpConf :: [HttpConfiguration] #endif #ifdef HTTPS_SUPPORT - , httpsConf :: [(HTTP.Settings,HTTPS.TLSSettings)] + , httpsConf :: [(HttpConfiguration,HttpsConfiguration)] #endif #ifdef FASTCGI_SUPPORT , fastCgiConf :: [FastCgiConfiguration] @@ -31,6 +32,36 @@ data Configuration = Configuration { #endif } +#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) +-- 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 +type BindPreference = String + +_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue +_BindPreference = Toml._String + +bindPreference :: Toml.Key -> TomlCodec BindPreference +bindPreference = Toml.match _BindPreference + +data HttpConfiguration = HttpConfiguration + { port :: Int + , bindPref :: BindPreference + } +httpDefaultSettings :: HttpConfiguration +httpDefaultSettings = HttpConfiguration 80 "*" +#endif + +#ifdef HTTPS_SUPPORT +data HttpsConfiguration = HttpsConfiguration + { certFile :: FilePath + , certChain :: [FilePath] + , keyFile :: FilePath + } +httpsDefaultSettings :: HttpsConfiguration +httpsDefaultSettings = HttpsConfiguration "certificate.pem" [] "key.pem" +#endif + #ifdef FASTCGI_SUPPORT data FastCgiConfiguration = FastCgiConfiguration #endif @@ -42,10 +73,10 @@ data CgiConfiguration = CgiConfiguration defaultConfiguration :: Configuration defaultConfiguration = Configuration () #ifdef HTTP_SUPPORT - [HTTP.defaultSettings] + [httpDefaultSettings] #endif #ifdef HTTPS_SUPPORT - [(HTTP.defaultSettings,HTTPS.defaultTlsSettings)] + [(httpDefaultSettings,httpsDefaultSettings)] #endif #ifdef FASTCGI_SUPPORT [FastCgiConfiguration] @@ -55,40 +86,28 @@ defaultConfiguration = Configuration () #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) +httpConfigCodec :: TomlCodec HttpConfiguration +httpConfigCodec = HttpConfiguration + <$> Toml.int "Port" .= port + <*> bindPreference "Bind" .= bindPref #endif #ifdef HTTPS_SUPPORT -httpsConfigCodec :: TomlCodec (HTTP.Settings,HTTPS.TLSSettings) +httpsConfigCodec :: TomlCodec (HttpConfiguration,HttpsConfiguration) httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' -httpsConfigCodec' :: TomlCodec (HTTPS.TLSSettings) -httpsConfigCodec' = HTTPS.tlsSettingsChain +httpsConfigCodec' :: TomlCodec HttpsConfiguration +httpsConfigCodec' = HttpsConfiguration -- the hardcoded strings are a bloody hack, but we can't extract the values back out of a config (they are there -- warp just doesn't export the neccesarry types). So we hardcode default values, which is kind of realy bad, but -- we don't need it in our usecase - <$> Toml.string "Certificate" .= (const "certificate.pem") - <*> Toml.arrayOf Toml._String "CertChain" .= (const []) - <*> Toml.string "KeyFile" .= (const "key.pem") + <$> Toml.string "Certificate" .= certFile + <*> Toml.arrayOf Toml._String "CertChain" .= certChain + <*> Toml.string "KeyFile" .= keyFile #endif #ifdef FASTCGI_SUPPORT From 04300a161ed8773de220c10de718c22c853fe395 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Mon, 5 Oct 2020 14:21:43 +0200 Subject: [PATCH 04/10] started refactor into seperate backend_files --- app/Backend/CGI.hs | 1 + app/Backend/FastCGI.hs | 1 + app/Backend/Http.hs | 54 ++++++++++++++++++++++++++++++++++++++++++ app/Backend/Https.hs | 1 + package.yaml | 1 + tickLeisteServer.cabal | 6 +++++ 6 files changed, 64 insertions(+) create mode 100644 app/Backend/CGI.hs create mode 100644 app/Backend/FastCGI.hs create mode 100644 app/Backend/Http.hs create mode 100644 app/Backend/Https.hs diff --git a/app/Backend/CGI.hs b/app/Backend/CGI.hs new file mode 100644 index 0000000..9f8997f --- /dev/null +++ b/app/Backend/CGI.hs @@ -0,0 +1 @@ +module Backend.CGI where diff --git a/app/Backend/FastCGI.hs b/app/Backend/FastCGI.hs new file mode 100644 index 0000000..e51ba7d --- /dev/null +++ b/app/Backend/FastCGI.hs @@ -0,0 +1 @@ +module Backend.FastCGI where diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs new file mode 100644 index 0000000..54e8de7 --- /dev/null +++ b/app/Backend/Http.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Backend.Http + ( HttpConfiguration (..), + httpDefaultSettings, + ) +where + +import Data.String +import qualified Data.Text as T +import Network.Wai.Handler.Warp as HTTP +import Toml (TomlCodec, (.=)) +import Control.Concurrent +import Control.Concurrent.MVar +import qualified Toml +import Validation + +-- 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 + { port :: Int, + bindPref :: BindPreference + } + +httpDefaultSettings :: HttpConfiguration +httpDefaultSettings = HttpConfiguration 80 "*" + +-- 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.int "Port" .= port + <*> bindPreference "Bind" .= bindPref + +forkHttpBackend :: Toml.TOML -> IO [MVar ()] +forkHttpBackend ast = undefined + diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs new file mode 100644 index 0000000..86e00e0 --- /dev/null +++ b/app/Backend/Https.hs @@ -0,0 +1 @@ +module Backend.Https where diff --git a/package.yaml b/package.yaml index e0ab188..c3bdb37 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,7 @@ dependencies: - wai-websockets - http-types - tomland +- validation-selective when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 7ea295a..8725117 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -46,6 +46,10 @@ flag https executable tickLeisteServer main-is: Main.hs other-modules: + Backend.CGI + Backend.FastCGI + Backend.Http + Backend.Https Config WaiApp WebSocketApp @@ -66,6 +70,7 @@ executable tickLeisteServer , tickLeiste-aeson , tomland , uuid + , validation-selective , wai , wai-websockets , websockets @@ -114,6 +119,7 @@ test-suite tickLeisteServer-test , tickLeisteServer , tomland , uuid + , validation-selective , wai , wai-websockets , websockets From 61ec499c0e5a0f7d315fd18390090c70a6fa771b Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Tue, 13 Oct 2020 13:28:03 +0200 Subject: [PATCH 05/10] refactor is in progress --- app/Backend/Http.hs | 40 +++++++++++++++++++++++++++++----------- app/Backend/Https.hs | 19 +++++++++++++++++++ app/Config.hs | 22 +++++++++++++++++++++- 3 files changed, 69 insertions(+), 12 deletions(-) diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index 54e8de7..824d055 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -3,17 +3,22 @@ module Backend.Http ( HttpConfiguration (..), httpDefaultSettings, + httpDefaultSetting, + forkHttpBackend, + httpConfigCodec, + httpConfigsCodec, ) where -import Data.String -import qualified Data.Text as T -import Network.Wai.Handler.Warp as HTTP -import Toml (TomlCodec, (.=)) +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 -import Validation -- 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 @@ -31,12 +36,16 @@ bindPreference :: Toml.Key -> TomlCodec BindPreference bindPreference = Toml.match _BindPreference data HttpConfiguration = HttpConfiguration - { port :: Int, + { instanceName :: T.Text, + port :: Int, bindPref :: BindPreference } -httpDefaultSettings :: HttpConfiguration -httpDefaultSettings = HttpConfiguration 80 "*" +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?? @@ -46,9 +55,18 @@ httpConfigConstructor port bind = HTTP.setPort port $ HTTP.setHost (fromString b httpConfigCodec :: TomlCodec HttpConfiguration httpConfigCodec = HttpConfiguration - <$> Toml.int "Port" .= port + <$> Toml.text "InstanceName" .= instanceName + <*> Toml.int "Port" .= port <*> bindPreference "Bind" .= bindPref -forkHttpBackend :: Toml.TOML -> IO [MVar ()] -forkHttpBackend ast = undefined +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 diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 86e00e0..d7f796a 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -1 +1,20 @@ module Backend.Https where + +import Backend.Http +import qualified Data.Text as T +import Toml (TomlCodec, (.=)) +import qualified Toml + +type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) + +data TLSConfiguration = TLSConfiguration + { cerfFile :: FilePath, + certChain :: [FilePath], + keyFile :: FilePath + } + +tlsDefaultSetting :: TLSConfiguration +tlsDefaultSetting = TLSConfiguration "certificate.pem" [] "key.pem" + +httpsDefaultSetting :: HttpsConfiguration +httpsDefaultSetting = (httpDefaultSetting, tlsDefaultSetting) diff --git a/app/Config.hs b/app/Config.hs index 6b7daf0..71ae534 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module Config(Configuration(..),defaultConfiguration,HttpConfiguration (..)) where +module Config(Configuration(..),forkBackend,withConfigs,forkWithConfigs) where import Toml (TomlCodec, (.=)) import qualified Toml import System.IO import qualified Data.Text as T +import Control.Concurrent.MVar +import Control.Concurrent +import WaiApp -- this module should handle everything connected to our TOML config #if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) @@ -134,3 +137,20 @@ configurationCodec = pure (Configuration ()) #ifdef CGI_SUPPORT <*> Toml.list cgiConfigCodec "cgi" .= cgiConf #endif + +forkWithConfigs :: (a -> IO ()) -> TomlCodec [a] -> FilePath -> IO [MVar ()] +forkWithConfigs f = withConfigs (\conf -> forkBackend $ f conf) + +withConfigs :: (a -> IO (MVar ())) -> TomlCodec [a] -> FilePath -> IO [MVar ()] +withConfigs f codec configFile = do + parseResult <- Toml.decodeFileEither codec configFile + either + (error "Logging not implemented") + (mapM f) + parseResult + +forkBackend :: IO () -> IO (MVar ()) +forkBackend f = do + mVar <- newEmptyMVar + forkFinally f (const $ putMVar mVar ()) + return mVar From 318ad08f74037464fbb0e0a05830cd731d4cd91e Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Wed, 14 Oct 2020 20:40:27 +0200 Subject: [PATCH 06/10] Https backend done --- app/Backend/Http.hs | 17 +++-------------- app/Backend/Https.hs | 41 ++++++++++++++++++++++++++++++++++++++--- hie.yaml | 6 ++++++ 3 files changed, 47 insertions(+), 17 deletions(-) create mode 100644 hie.yaml diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index 824d055..52a58bb 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +-- we export a bit more than we have to, because the https module can reuse these things. module Backend.Http ( HttpConfiguration (..), httpDefaultSettings, @@ -7,12 +8,12 @@ module Backend.Http forkHttpBackend, httpConfigCodec, httpConfigsCodec, + httpToWarpConfig, ) where import Config -import Control.Concurrent -import Control.Concurrent.MVar +import Control.Concurrent.MVar(MVar) import Data.String import qualified Data.Text as T import qualified Network.Wai as Wai @@ -20,13 +21,6 @@ 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 @@ -47,11 +41,6 @@ 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 diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index d7f796a..4832649 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -1,14 +1,21 @@ -module Backend.Https where +{-# LANGUAGE OverloadedStrings #-} + +module Backend.Https (forkHttpsBackend, httpsDefaultSettings) where import Backend.Http -import qualified Data.Text as T +import Config +import Control.Concurrent.MVar (MVar) +import Data.Text () -- we only need the isString instance to generate literals +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as HTTP +import qualified Network.Wai.Handler.WarpTLS as HTTPS import Toml (TomlCodec, (.=)) import qualified Toml type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) data TLSConfiguration = TLSConfiguration - { cerfFile :: FilePath, + { certFile :: FilePath, certChain :: [FilePath], keyFile :: FilePath } @@ -18,3 +25,31 @@ tlsDefaultSetting = TLSConfiguration "certificate.pem" [] "key.pem" httpsDefaultSetting :: HttpsConfiguration httpsDefaultSetting = (httpDefaultSetting, tlsDefaultSetting) + +httpsDefaultSettings :: [HttpsConfiguration] +httpsDefaultSettings = [httpsDefaultSetting] + +httpsConfigCodec' :: TomlCodec TLSConfiguration +httpsConfigCodec' = + TLSConfiguration + <$> Toml.string "Certificate" .= certFile + <*> Toml.arrayOf Toml._String "CertChain" .= certChain + <*> Toml.string "KeyFile" .= keyFile + +httpsConfigCodec :: TomlCodec HttpsConfiguration +httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' + +httpsConfigsCodec :: TomlCodec [HttpsConfiguration] +httpsConfigsCodec = Toml.list httpsConfigCodec "https" + +forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] +forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile + +httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings +httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain (certFile tlsConfig) (certChain tlsConfig) (keyFile tlsConfig) + +httpsToWarpConfig :: HttpsConfiguration -> HTTP.Settings +httpsToWarpConfig = httpToWarpConfig . fst + +backend :: Wai.Application -> HttpsConfiguration -> IO () +backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..89544a0 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./app/" + component: "tickLeisteServer:exe:tickLeisteServer" + - path: "./test/" + component: "tickLeisteServer:test:tickLeisteServer-test" From aa785c47901878a6fbb9f83c7bb21734c83bcdb0 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Thu, 15 Oct 2020 05:41:36 +0200 Subject: [PATCH 07/10] changed https default config --- app/Backend/Https.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 4832649..77a2786 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -24,7 +24,7 @@ tlsDefaultSetting :: TLSConfiguration tlsDefaultSetting = TLSConfiguration "certificate.pem" [] "key.pem" httpsDefaultSetting :: HttpsConfiguration -httpsDefaultSetting = (httpDefaultSetting, tlsDefaultSetting) +httpsDefaultSetting = (HttpConfiguration "https" 443 "*", tlsDefaultSetting) httpsDefaultSettings :: [HttpsConfiguration] httpsDefaultSettings = [httpsDefaultSetting] From 4733c3e3e242b75a792be0b4655c4d974e0c4703 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Sun, 14 Mar 2021 19:19:59 +0100 Subject: [PATCH 08/10] updated tickLeiste submodule --- tickLeiste | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tickLeiste b/tickLeiste index 4af9f88..10318ad 160000 --- a/tickLeiste +++ b/tickLeiste @@ -1 +1 @@ -Subproject commit 4af9f88b839c00ba22f36ba5d003459f7efbe04b +Subproject commit 10318ade8cef231843ac2b95ce51d0a2986feeb9 From c4a1a442f35622e3d392ab772df6acc922a434ee Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Thu, 18 Mar 2021 15:31:59 +0100 Subject: [PATCH 09/10] redone backend handling and config parsing --- app/Backend/Backend.hs | 39 +++++++++++ app/Backend/CGI.hs | 3 + app/Backend/Http.hs | 43 ++++++++---- app/Backend/Https.hs | 41 +++++++++--- app/Config.hs | 145 +++++------------------------------------ app/Main.hs | 63 +++++++++++++----- app/WebSocketApp.hs | 3 +- package.yaml | 1 + tickLeisteServer.cabal | 5 +- 9 files changed, 177 insertions(+), 166 deletions(-) create mode 100644 app/Backend/Backend.hs diff --git a/app/Backend/Backend.hs b/app/Backend/Backend.hs new file mode 100644 index 0000000..0229b90 --- /dev/null +++ b/app/Backend/Backend.hs @@ -0,0 +1,39 @@ +module Backend.Backend where + +import Control.Concurrent.MVar +import qualified Network.Wai as Wai + +#ifdef HTTP_SUPPORT +import qualified Backend.Http as HTTP +#endif +#ifdef HTTPS_SUPPORT +import qualified Backend.Https as HTTPS +#endif + +-- maybe we want a String instead of T.Text depends on +-- the argument parser + +-- A backend consists of three things, The backend action, a Text to be +-- used as the command line option Flag, and a Bool if it has a config file. +-- +-- The backend action must be non blocking and fork the backend, the returned +-- list of MVar is there to communicate the termination of the backend. (The main +-- threat will wait till all MVar are present (not neccesarry at once)). +-- The action takes two parameter, the application the backend should run and +-- the path of the config File. If the Bool is False there are no guarantees on the FilePath +-- and the action should not try to evaluate the FilePath. +-- type Backend = (Wai.Application -> FilePath -> IO [MVar ()],T.Text,Bool) + +data Backend = + BackendWithConfig (Wai.Application -> FilePath -> IO [MVar ()]) String String + | BackendWithoutConfig (Wai.Application -> IO [MVar ()]) String String + +backends :: [Backend] +backends = +#ifdef HTTP_SUPPORT + BackendWithConfig HTTP.forkHttpBackend "http" "Host as a simple http server, using Warp" : +#endif +#ifdef HTTPS_SUPPORT + BackendWithConfig HTTPS.forkHttpsBackend "https" "Host as as simple https server, using Warp" : +#endif + [] diff --git a/app/Backend/CGI.hs b/app/Backend/CGI.hs index 9f8997f..cc600eb 100644 --- a/app/Backend/CGI.hs +++ b/app/Backend/CGI.hs @@ -1 +1,4 @@ module Backend.CGI where + + + diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index 52a58bb..3bedc98 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -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 diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 77a2786..559d88f 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -3,7 +3,8 @@ module Backend.Https (forkHttpsBackend, httpsDefaultSettings) where import Backend.Http -import Config +import Config hiding (ConfigM,configM) +import qualified Config as Toml (configM,ConfigM) import Control.Concurrent.MVar (MVar) import Data.Text () -- we only need the isString instance to generate literals import qualified Network.Wai as Wai @@ -15,16 +16,30 @@ import qualified Toml type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) data TLSConfiguration = TLSConfiguration - { certFile :: FilePath, - certChain :: [FilePath], - keyFile :: FilePath + { certFile :: Toml.ConfigM FilePath, + certChain :: Toml.ConfigM [FilePath], + keyFile :: Toml.ConfigM FilePath } +instance Semigroup TLSConfiguration where + a <> b = TLSConfiguration { + certFile = certFile a <> certFile b, + certChain = certChain a <> certChain b, + keyFile = keyFile a <> keyFile b + } + +instance Monoid TLSConfiguration where + mempty = TLSConfiguration mempty mempty mempty + tlsDefaultSetting :: TLSConfiguration -tlsDefaultSetting = TLSConfiguration "certificate.pem" [] "key.pem" +tlsDefaultSetting = TLSConfiguration { + certFile = setConfigM "certificate.pem", + certChain = setConfigM [], + keyFile = setConfigM "key.pem" + } httpsDefaultSetting :: HttpsConfiguration -httpsDefaultSetting = (HttpConfiguration "https" 443 "*", tlsDefaultSetting) +httpsDefaultSetting = (HttpConfiguration (setConfigM "https") (setConfigM 443) (setConfigM "*"), tlsDefaultSetting) httpsDefaultSettings :: [HttpsConfiguration] httpsDefaultSettings = [httpsDefaultSetting] @@ -32,9 +47,9 @@ httpsDefaultSettings = [httpsDefaultSetting] httpsConfigCodec' :: TomlCodec TLSConfiguration httpsConfigCodec' = TLSConfiguration - <$> Toml.string "Certificate" .= certFile - <*> Toml.arrayOf Toml._String "CertChain" .= certChain - <*> Toml.string "KeyFile" .= keyFile + <$> Toml.configM Toml.string "Certificate" .= certFile + <*> Toml.configM (Toml.arrayOf Toml._String) "CertChain" .= certChain + <*> Toml.configM Toml.string "KeyFile" .= keyFile httpsConfigCodec :: TomlCodec HttpsConfiguration httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' @@ -46,7 +61,13 @@ forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings -httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain (certFile tlsConfig) (certChain tlsConfig) (keyFile tlsConfig) +httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain confCerfFile confCertChain confKeyFile + where + -- this has always all options set so getConfigM is safe + config = tlsConfig <> tlsDefaultSetting + confCerfFile = getConfigM $ certFile config + confCertChain = getConfigM $ certChain config + confKeyFile = getConfigM $ keyFile config httpsToWarpConfig :: HttpsConfiguration -> HTTP.Settings httpsToWarpConfig = httpToWarpConfig . fst diff --git a/app/Config.hs b/app/Config.hs index 71ae534..fcae9e3 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Config(Configuration(..),forkBackend,withConfigs,forkWithConfigs) where - +module Config(forkBackend,withConfigs,forkWithConfigs,ConfigM,configM,getConfigM,setConfigM) where + +import Data.Semigroup + + import Toml (TomlCodec, (.=)) import qualified Toml import System.IO @@ -8,138 +11,26 @@ import qualified Data.Text as T import Control.Concurrent.MVar import Control.Concurrent import WaiApp +import Data.Maybe(fromJust) +import Data.Coerce --- 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 +-- This Type is here to replace Toml.Codec.Monoid.First as the First Monoid +-- will be replaced with Maybe First with the First Semigroup +type ConfigM a = Maybe (First a) -data Configuration = Configuration - { cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor -#ifdef HTTP_SUPPORT - , httpConf :: [HttpConfiguration] -#endif -#ifdef HTTPS_SUPPORT - , httpsConf :: [(HttpConfiguration,HttpsConfiguration)] -#endif -#ifdef FASTCGI_SUPPORT - , fastCgiConf :: [FastCgiConfiguration] -#endif -#ifdef CGI_SUPPORT - , cgiConf :: [CgiConfiguration] -#endif - } +-- WARNING this function IS NOT total be sure the option is given! +getConfigM :: ConfigM a -> a +getConfigM = coerce . fromJust -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) --- 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 -type BindPreference = String +setConfigM :: a -> ConfigM a +setConfigM = Just . coerce -_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue -_BindPreference = Toml._String - -bindPreference :: Toml.Key -> TomlCodec BindPreference -bindPreference = Toml.match _BindPreference - -data HttpConfiguration = HttpConfiguration - { port :: Int - , bindPref :: BindPreference - } -httpDefaultSettings :: HttpConfiguration -httpDefaultSettings = HttpConfiguration 80 "*" -#endif - -#ifdef HTTPS_SUPPORT -data HttpsConfiguration = HttpsConfiguration - { certFile :: FilePath - , certChain :: [FilePath] - , keyFile :: FilePath - } -httpsDefaultSettings :: HttpsConfiguration -httpsDefaultSettings = HttpsConfiguration "certificate.pem" [] "key.pem" -#endif - -#ifdef FASTCGI_SUPPORT -data FastCgiConfiguration = FastCgiConfiguration -#endif - -#ifdef CGI_SUPPORT -data CgiConfiguration = CgiConfiguration -#endif - -defaultConfiguration :: Configuration -defaultConfiguration = Configuration () -#ifdef HTTP_SUPPORT - [httpDefaultSettings] -#endif -#ifdef HTTPS_SUPPORT - [(httpDefaultSettings,httpsDefaultSettings)] -#endif -#ifdef FASTCGI_SUPPORT - [FastCgiConfiguration] -#endif -#ifdef CGI_SUPPORT - [CgiConfiguration] -#endif - -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) --- 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.int "Port" .= port - <*> bindPreference "Bind" .= bindPref -#endif - -#ifdef HTTPS_SUPPORT -httpsConfigCodec :: TomlCodec (HttpConfiguration,HttpsConfiguration) -httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' - -httpsConfigCodec' :: TomlCodec HttpsConfiguration -httpsConfigCodec' = HttpsConfiguration --- the hardcoded strings are a bloody hack, but we can't extract the values back out of a config (they are there --- warp just doesn't export the neccesarry types). So we hardcode default values, which is kind of realy bad, but --- we don't need it in our usecase - <$> Toml.string "Certificate" .= certFile - <*> Toml.arrayOf Toml._String "CertChain" .= certChain - <*> Toml.string "KeyFile" .= keyFile -#endif - -#ifdef FASTCGI_SUPPORT -fastCgiConfigCodec :: TomlCodec FastCgiConfiguration -fastCgiConfigCodec = pure FastCgiConfiguration -#endif - -#ifdef CGI_SUPPORT -cgiConfigCodec :: TomlCodec CgiConfiguration -cgiConfigCodec = pure CgiConfiguration -#endif - -configurationCodec :: TomlCodec Configuration -configurationCodec = pure (Configuration ()) -#ifdef HTTP_SUPPORT - <*> Toml.list httpConfigCodec "http" .= httpConf -#endif -#ifdef HTTPS_SUPPORT - <*> Toml.list httpsConfigCodec "https" .= httpsConf -#endif -#ifdef FASTCGI_SUPPORT - <*> Toml.list fastCgiConfigCodec "fast-cgi" .= fastCgiConf -#endif -#ifdef CGI_SUPPORT - <*> Toml.list cgiConfigCodec "cgi" .= cgiConf -#endif +configM :: (Toml.Key -> TomlCodec a) -> Toml.Key -> TomlCodec (ConfigM a) +configM codec = Toml.diwrap . Toml.dioptional . codec forkWithConfigs :: (a -> IO ()) -> TomlCodec [a] -> FilePath -> IO [MVar ()] -forkWithConfigs f = withConfigs (\conf -> forkBackend $ f conf) +forkWithConfigs f = withConfigs (forkBackend . f) withConfigs :: (a -> IO (MVar ())) -> TomlCodec [a] -> FilePath -> IO [MVar ()] withConfigs f codec configFile = do diff --git a/app/Main.hs b/app/Main.hs index 5966cfa..e62bd02 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,8 +9,11 @@ module Main where -- see Network.Wai.Handler.Warp.Settings and Network.Wai.Handler.Warp.runSettings import Control.Concurrent.MVar +import qualified Network.Wai as Wai import WaiApp import Control.Concurrent +import Backend.Backend +import Options.Applicative #ifdef HTTP_SUPPORT import qualified Network.Wai.Handler.Warp as HTTP @@ -29,21 +32,51 @@ 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) +-- maybe we should use Control.Concurrent.ParallelIO but right +-- now we just rely that the backends fork and don't block main :: IO () main = do + options <- execParser commandLineParser serverState <- newMVar newServerState -#ifdef HTTP_SUPPORT - HTTP.runSettings HTTP.defaultSettings $ waiApplication serverState -#endif -#ifdef HTTPS_SUPPORT - HTTPS.runTLS HTTPS.defaultTlsSettings HTTP.defaultSettings $ waiApplication serverState -#endif -#ifdef FASTCGI_SUPPORT - FastCGI.run $ waiApplication serverState -#endif -#ifdef CGI_SUPPORT - CGI.run $ waiApplication serverState -#endif - return () + let backs = zipWith (runBackend $ waiApplication serverState) options backends + waitFor' <- sequence backs + let waitFor = concat waitFor' + blockBackends waitFor + +blockBackends :: [MVar ()] -> IO () +blockBackends = mapM_ takeMVar + +runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> IO [MVar ()] +runBackend app (Left (Just conf)) (BackendWithConfig b _ _) = b app conf +runBackend _ (Left Nothing) (BackendWithConfig _ _ _) = return [] +runBackend app (Right True) (BackendWithoutConfig b _ _) = b app +runBackend _ (Right False) (BackendWithoutConfig _ _ _) = return [] +runBackend _ _ _ = error "Backend and parser type don't match! THIS IS A BUG" + +commandLineParser :: ParserInfo [Either (Maybe String) Bool] +commandLineParser = info (combineParser ( fmap backendToParser backends) <**> helper) + ( fullDesc + <> progDesc "a small tickLeiste Server to play Splittermond with your crew" ) + +backendToParser :: Backend -> ParserType +backendToParser (BackendWithConfig _ name desc) = Left $ optional (strOption (long name <> help desc <> metavar "ConfigFile")) +backendToParser (BackendWithoutConfig _ name desc) = Right $ switch (long name <> help desc) + +type ParserType = Either (Parser (Maybe String)) (Parser Bool) + +combineParser :: [ParserType] -> Parser [Either (Maybe String) Bool] +combineParser = combineApplicativeList . fmap swapFunctorEither + +-- TODO swap is a bad name, as the reversal of those operations is unclear +-- at best (and that means impossible, if you want it to do something sensible) +-- TODO this feels like the Left and the Right case could be handled +-- in one case, but I don't know how to write that +-- (except with ||| from the Arrow lib but that feels like a stupid dependency +-- for one line) But Maybe there is a better solution using Arrow altogether +-- (optparse has arrow instances) +swapFunctorEither :: Functor f => Either (f a) (f b) -> f (Either a b) +swapFunctorEither (Left p) = fmap Left p +swapFunctorEither (Right p) = fmap Right p + +combineApplicativeList :: Applicative f => [f a] -> f [a] +combineApplicativeList = foldr ((<*>) . fmap (:)) (pure []) diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index dce3f37..adb5af5 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -77,6 +77,7 @@ clientLogic conn sessionStateMVar = do hPrint stderr msg ) -- the next line is a bit ugly, maybe there is a better way? + -- maybe refactor, so that the request Handler can choose to lock or not. -- TODO (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler conn sessionState request)) (decodeStrict msg :: Maybe TL.JSONRequest) clientLogic conn sessionStateMVar @@ -102,7 +103,7 @@ requestHandler conn (tl, pl, cls, sem) (TL.InitializeTickLeisteR preTickLeiste) -- TODO -- Also TickLeisteR must be inside the modifyMVar, because we use the MVar also as a lock, and we can't --- have changes between reading the TickLeiste and sending it. +-- have changes between reading the TickLeiste and sending the information. requestHandler conn ss@(tl, pl, cls, sem) TL.TickLeisteR = do sendClientEvent (TL.InitializeTickLeisteE $ tickLeisteToPlayerList pl tl) conn return ss diff --git a/package.yaml b/package.yaml index c3bdb37..9d3610e 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - http-types - tomland - validation-selective +- optparse-applicative when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 8725117..b948254 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -46,6 +46,7 @@ flag https executable tickLeisteServer main-is: Main.hs other-modules: + Backend.Backend Backend.CGI Backend.FastCGI Backend.Http @@ -65,6 +66,7 @@ executable tickLeisteServer , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson @@ -113,6 +115,7 @@ test-suite tickLeisteServer-test , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson From d202c777d23d764b521b7c858d9bc7d56c5aca3f Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Thu, 18 Mar 2021 16:34:29 +0100 Subject: [PATCH 10/10] small annotation for later --- app/Config.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/app/Config.hs b/app/Config.hs index fcae9e3..34148f9 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -40,6 +40,8 @@ withConfigs f codec configFile = do (mapM f) parseResult +-- Note for later: +-- TODO this may need logging if f dies with an exception forkBackend :: IO () -> IO (MVar ()) forkBackend f = do mVar <- newEmptyMVar