redone backend handling and config parsing

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
+  []

app/Backend/CGI.hs

@@ -1 +1,4 @@
 module Backend.CGI where
+
+
+

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,
+  { instanceName :: Toml.ConfigM T.Text,
-    port :: Int,
+    port :: Toml.ConfigM Int,
-    bindPref :: BindPreference
+    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.configM Toml.text "InstanceName" .= instanceName
-    <*> Toml.int "Port" .= port
+    <*> Toml.configM Toml.int  "Port"         .= port
-    <*> bindPreference "Bind" .= bindPref
+    <*> 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

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,
+  { certFile  :: Toml.ConfigM FilePath,
-    certChain :: [FilePath],
+    certChain :: Toml.ConfigM [FilePath],
-    keyFile :: 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.configM Toml.string "Certificate"               .= certFile
-    <*> Toml.arrayOf Toml._String "CertChain" .= certChain
+    <*> Toml.configM (Toml.arrayOf Toml._String) "CertChain" .= certChain
-    <*> Toml.string "KeyFile" .= keyFile
+    <*> 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

app/Config.hs

@@ -1,5 +1,8 @@
 {-# 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
@@ -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
+-- This Type is here to replace Toml.Codec.Monoid.First as the First Monoid
-import qualified Network.Wai.Handler.WarpTLS as HTTPS
+-- will be replaced with Maybe First with the First Semigroup
-#endif
+type ConfigM a = Maybe (First a)
 
-data Configuration = Configuration
+-- WARNING this function IS NOT total be sure the option is given!
-  { cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor
+getConfigM :: ConfigM a -> a
-#ifdef HTTP_SUPPORT
+getConfigM = coerce . fromJust
-  , httpConf :: [HttpConfiguration]
-#endif
-#ifdef HTTPS_SUPPORT
-  , httpsConf :: [(HttpConfiguration,HttpsConfiguration)]
-#endif
-#ifdef FASTCGI_SUPPORT
-  , fastCgiConf :: [FastCgiConfiguration]
-#endif
-#ifdef CGI_SUPPORT
-  , cgiConf :: [CgiConfiguration]
-#endif
-  }
 
-#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT)
+setConfigM :: a -> ConfigM a
--- We leave it as a Text here and defer the conversion to the warp type to the last possible moment.
+setConfigM = Just . coerce
--- 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
+configM :: (Toml.Key -> TomlCodec a) -> Toml.Key -> TomlCodec (ConfigM a)
-_BindPreference = Toml._String
+configM codec = Toml.diwrap . Toml.dioptional . codec
-
-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
 
 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

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
+-- maybe we should use Control.Concurrent.ParallelIO but right
--- then wait till all of them terminated)
+-- 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
+  let backs = zipWith (runBackend $ waiApplication serverState) options backends
-  HTTP.runSettings HTTP.defaultSettings $ waiApplication serverState
+  waitFor' <- sequence backs
-#endif
+  let waitFor = concat waitFor'
-#ifdef HTTPS_SUPPORT
+  blockBackends waitFor
-  HTTPS.runTLS HTTPS.defaultTlsSettings HTTP.defaultSettings $ waiApplication serverState
+
-#endif
+blockBackends :: [MVar ()] -> IO ()
-#ifdef FASTCGI_SUPPORT
+blockBackends = mapM_ takeMVar
-  FastCGI.run $ waiApplication serverState
+
-#endif
+runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> IO [MVar ()]
-#ifdef CGI_SUPPORT
+runBackend app (Left (Just conf))  (BackendWithConfig    b _ _) = b app conf
-  CGI.run $ waiApplication serverState
+runBackend _   (Left Nothing)      (BackendWithConfig    _ _ _) = return []
-#endif
+runBackend app (Right True)        (BackendWithoutConfig b _ _) = b app
-  return ()
+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 [])

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

package.yaml

@@ -52,6 +52,7 @@ dependencies:
 - http-types
 - tomland
 - validation-selective
+- optparse-applicative
 
 when:
   - condition: flag(http)

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