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