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,
-    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

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