Splittertech/tickLeisteServer
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

wrapped everything in the EnvM Monad, the logging might commence

Browse source
This commit is contained in:
Dennis Frieberg 2021-04-05 22:11:07 +02:00
parent 27a51c2121
commit ac303abcc0
7 changed files with 78 additions and 51 deletions
Download patch file Download diff file Expand all files Collapse all files

5
app/Backend/Backend.hs
View file

@ -3,6 +3,7 @@ module Backend.Backend where
import Control.Concurrent.MVar
import qualified Network.Wai as Wai
import Environment
#ifdef HTTP_SUPPORT
import qualified Backend.Http as HTTP
@ -25,8 +26,8 @@ import qualified Backend.Https as HTTPS
-- 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
BackendWithConfig (Wai.Application -> FilePath -> EnvM [MVar ()]) String String
| BackendWithoutConfig (Wai.Application -> EnvM [MVar ()]) String String
backends :: [Backend]
backends =

13
app/Backend/Http.hs
View file

@ -3,9 +3,8 @@
module Backend.Http
where
#endif
#ifdef HTTP_SUPPORT
#else
{-# LANGUAGE OverloadedStrings #-}
-- we export a bit more than we have to, because the https module can reuse these things.
@ -32,6 +31,8 @@ import qualified Toml
import Data.Semigroup (getFirst, First(..))
import Data.Maybe(fromJust)
import Data.Coerce
import Environment
import Control.Monad.IO.Class
type BindPreference = String
@ -73,8 +74,8 @@ httpConfigCodec =
httpConfigsCodec :: TomlCodec [HttpConfiguration]
httpConfigsCodec = Toml.list httpConfigCodec "http"
forkHttpBackend :: Wai.Application -> FilePath -> IO [MVar ()]
forkHttpBackend app configFile = forkWithConfigs (backend app) httpConfigsCodec configFile
forkHttpBackend :: Wai.Application -> FilePath -> EnvM [MVar ()]
forkHttpBackend app = forkWithConfigs (backend app) httpConfigsCodec
httpToWarpConfig :: HttpConfiguration -> HTTP.Settings
httpToWarpConfig config' = HTTP.setPort confPort $ HTTP.setHost (fromString confBindPref) HTTP.defaultSettings
@ -84,6 +85,6 @@ httpToWarpConfig config' = HTTP.setPort confPort $ HTTP.setHost (fromString conf
confBindPref = getConfigM $ bindPref config
backend :: Wai.Application -> HttpConfiguration -> IO ()
backend app config = HTTP.runSettings (httpToWarpConfig config) app
backend :: Wai.Application -> HttpConfiguration -> EnvM ()
backend app config = liftIO $ HTTP.runSettings (httpToWarpConfig config) app
#endif

10
app/Backend/Https.hs
View file

@ -18,6 +18,8 @@ import qualified Network.Wai.Handler.Warp as HTTP
import qualified Network.Wai.Handler.WarpTLS as HTTPS
import Toml (TomlCodec, (.=))
import qualified Toml
import Control.Monad.IO.Class
import Environment
type HttpsConfiguration = (HttpConfiguration, TLSConfiguration)
@ -63,8 +65,8 @@ httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec'
httpsConfigsCodec :: TomlCodec [HttpsConfiguration]
httpsConfigsCodec = Toml.list httpsConfigCodec "https"
forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()]
forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile
forkHttpsBackend :: Wai.Application -> FilePath -> EnvM [MVar ()]
forkHttpsBackend app = forkWithConfigs (backend app) httpsConfigsCodec
httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings
httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain confCerfFile confCertChain confKeyFile
@ -78,6 +80,6 @@ httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain confCerfFile confCe
httpsToWarpConfig :: HttpsConfiguration -> HTTP.Settings
httpsToWarpConfig = httpToWarpConfig . fst
backend :: Wai.Application -> HttpsConfiguration -> IO ()
backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app
backend :: Wai.Application -> HttpsConfiguration -> EnvM ()
backend app conf = liftIO $ HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app
#endif