refactor is in progress

app/Backend/Http.hs

@@ -3,17 +3,22 @@
 module Backend.Http
   ( HttpConfiguration (..),
     httpDefaultSettings,
+    httpDefaultSetting,
+    forkHttpBackend,
+    httpConfigCodec,
+    httpConfigsCodec,
   )
 where
 
-import Data.String
+import Config
-import qualified Data.Text as T
-import Network.Wai.Handler.Warp as HTTP
-import Toml (TomlCodec, (.=))
 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
+httpDefaultSetting :: HttpConfiguration
-httpDefaultSettings = HttpConfiguration 80 "*"
+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 ()]
+httpConfigsCodec :: TomlCodec [HttpConfiguration]
-forkHttpBackend ast = undefined
+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

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)

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