refactor is in progress

This commit is contained in:
Dennis Frieberg 2020-10-13 13:28:03 +02:00
parent 04300a161e
commit 61ec499c0e
3 changed files with 69 additions and 12 deletions

View file

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

View file

@ -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)

View file

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