diff --git a/app/Backend/Backend.hs b/app/Backend/Backend.hs new file mode 100644 index 0000000..0229b90 --- /dev/null +++ b/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 + [] diff --git a/app/Backend/CGI.hs b/app/Backend/CGI.hs new file mode 100644 index 0000000..cc600eb --- /dev/null +++ b/app/Backend/CGI.hs @@ -0,0 +1,4 @@ +module Backend.CGI where + + + diff --git a/app/Backend/FastCGI.hs b/app/Backend/FastCGI.hs new file mode 100644 index 0000000..e51ba7d --- /dev/null +++ b/app/Backend/FastCGI.hs @@ -0,0 +1 @@ +module Backend.FastCGI where diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs new file mode 100644 index 0000000..3bedc98 --- /dev/null +++ b/app/Backend/Http.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- we export a bit more than we have to, because the https module can reuse these things. +module Backend.Http + ( HttpConfiguration (..), + httpDefaultSettings, + httpDefaultSetting, + forkHttpBackend, -- key export + httpConfigCodec, + httpConfigsCodec, + httpToWarpConfig, + ) +where + +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 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 + +_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue +_BindPreference = Toml._String + +bindPreference :: Toml.Key -> TomlCodec BindPreference +bindPreference = Toml.match _BindPreference + +data HttpConfiguration = HttpConfiguration + { 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 (setConfigM ("http" :: T.Text)) (setConfigM (80 :: Int)) (setConfigM ("*" :: BindPreference)) + +httpDefaultSettings :: [HttpConfiguration] +httpDefaultSettings = [httpDefaultSetting] + +httpConfigCodec :: TomlCodec HttpConfiguration +httpConfigCodec = + HttpConfiguration + <$> 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" + +forkHttpBackend :: Wai.Application -> FilePath -> IO [MVar ()] +forkHttpBackend app configFile = forkWithConfigs (backend app) httpConfigsCodec configFile + +httpToWarpConfig :: HttpConfiguration -> HTTP.Settings +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 diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs new file mode 100644 index 0000000..559d88f --- /dev/null +++ b/app/Backend/Https.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Backend.Https (forkHttpsBackend, httpsDefaultSettings) where + +import Backend.Http +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 +import qualified Network.Wai.Handler.Warp as HTTP +import qualified Network.Wai.Handler.WarpTLS as HTTPS +import Toml (TomlCodec, (.=)) +import qualified Toml + +type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) + +data TLSConfiguration = TLSConfiguration + { 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 { + certFile = setConfigM "certificate.pem", + certChain = setConfigM [], + keyFile = setConfigM "key.pem" + } + +httpsDefaultSetting :: HttpsConfiguration +httpsDefaultSetting = (HttpConfiguration (setConfigM "https") (setConfigM 443) (setConfigM "*"), tlsDefaultSetting) + +httpsDefaultSettings :: [HttpsConfiguration] +httpsDefaultSettings = [httpsDefaultSetting] + +httpsConfigCodec' :: TomlCodec TLSConfiguration +httpsConfigCodec' = + TLSConfiguration + <$> 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' + +httpsConfigsCodec :: TomlCodec [HttpsConfiguration] +httpsConfigsCodec = Toml.list httpsConfigCodec "https" + +forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] +forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile + +httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings +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 + +backend :: Wai.Application -> HttpsConfiguration -> IO () +backend app conf = HTTPS.runTLS (httpsToWarpTLSConfig conf) (httpsToWarpConfig conf) app diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..34148f9 --- /dev/null +++ b/app/Config.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +module Config(forkBackend,withConfigs,forkWithConfigs,ConfigM,configM,getConfigM,setConfigM) where + +import Data.Semigroup + + +import Toml (TomlCodec, (.=)) +import qualified Toml +import System.IO +import qualified Data.Text as T +import Control.Concurrent.MVar +import Control.Concurrent +import WaiApp +import Data.Maybe(fromJust) +import Data.Coerce + + +-- This Type is here to replace Toml.Codec.Monoid.First as the First Monoid +-- will be replaced with Maybe First with the First Semigroup +type ConfigM a = Maybe (First a) + +-- WARNING this function IS NOT total be sure the option is given! +getConfigM :: ConfigM a -> a +getConfigM = coerce . fromJust + +setConfigM :: a -> ConfigM a +setConfigM = Just . coerce + +configM :: (Toml.Key -> TomlCodec a) -> Toml.Key -> TomlCodec (ConfigM a) +configM codec = Toml.diwrap . Toml.dioptional . codec + +forkWithConfigs :: (a -> IO ()) -> TomlCodec [a] -> FilePath -> IO [MVar ()] +forkWithConfigs f = withConfigs (forkBackend . f) + +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 + +-- Note for later: +-- TODO this may need logging if f dies with an exception +forkBackend :: IO () -> IO (MVar ()) +forkBackend f = do + mVar <- newEmptyMVar + forkFinally f (const $ putMVar mVar ()) + return mVar diff --git a/app/Main.hs b/app/Main.hs index 00c8593..e62bd02 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,7 +9,11 @@ module Main where -- see Network.Wai.Handler.Warp.Settings and Network.Wai.Handler.Warp.runSettings import Control.Concurrent.MVar +import qualified Network.Wai as Wai import WaiApp +import Control.Concurrent +import Backend.Backend +import Options.Applicative #ifdef HTTP_SUPPORT import qualified Network.Wai.Handler.Warp as HTTP @@ -28,19 +32,51 @@ import qualified Network.Wai.Handler.FastCGI as FastCGI import qualified Network.Wai.Handler.CGI as CGI #endif +-- maybe we should use Control.Concurrent.ParallelIO but right +-- now we just rely that the backends fork and don't block main :: IO () main = do + options <- execParser commandLineParser serverState <- newMVar newServerState -#ifdef HTTP_SUPPORT - HTTP.runSettings HTTP.defaultSettings $ waiApplication serverState -#endif -#ifdef HTTPS_SUPPORT - HTTPS.runTLS HTTPS.defaultTlsSettings HTTP.defaultSettings $ waiApplication serverState -#endif -#ifdef FASTCGI_SUPPORT - FastCGI.run $ waiApplication serverState -#endif -#ifdef CGI_SUPPORT - CGI.run $ waiApplication serverState -#endif - return () + let backs = zipWith (runBackend $ waiApplication serverState) options backends + waitFor' <- sequence backs + let waitFor = concat waitFor' + blockBackends waitFor + +blockBackends :: [MVar ()] -> IO () +blockBackends = mapM_ takeMVar + +runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> IO [MVar ()] +runBackend app (Left (Just conf)) (BackendWithConfig b _ _) = b app conf +runBackend _ (Left Nothing) (BackendWithConfig _ _ _) = return [] +runBackend app (Right True) (BackendWithoutConfig b _ _) = b app +runBackend _ (Right False) (BackendWithoutConfig _ _ _) = return [] +runBackend _ _ _ = error "Backend and parser type don't match! THIS IS A BUG" + +commandLineParser :: ParserInfo [Either (Maybe String) Bool] +commandLineParser = info (combineParser ( fmap backendToParser backends) <**> helper) + ( fullDesc + <> progDesc "a small tickLeiste Server to play Splittermond with your crew" ) + +backendToParser :: Backend -> ParserType +backendToParser (BackendWithConfig _ name desc) = Left $ optional (strOption (long name <> help desc <> metavar "ConfigFile")) +backendToParser (BackendWithoutConfig _ name desc) = Right $ switch (long name <> help desc) + +type ParserType = Either (Parser (Maybe String)) (Parser Bool) + +combineParser :: [ParserType] -> Parser [Either (Maybe String) Bool] +combineParser = combineApplicativeList . fmap swapFunctorEither + +-- TODO swap is a bad name, as the reversal of those operations is unclear +-- at best (and that means impossible, if you want it to do something sensible) +-- TODO this feels like the Left and the Right case could be handled +-- in one case, but I don't know how to write that +-- (except with ||| from the Arrow lib but that feels like a stupid dependency +-- for one line) But Maybe there is a better solution using Arrow altogether +-- (optparse has arrow instances) +swapFunctorEither :: Functor f => Either (f a) (f b) -> f (Either a b) +swapFunctorEither (Left p) = fmap Left p +swapFunctorEither (Right p) = fmap Right p + +combineApplicativeList :: Applicative f => [f a] -> f [a] +combineApplicativeList = foldr ((<*>) . fmap (:)) (pure []) diff --git a/app/WebSocketApp.hs b/app/WebSocketApp.hs index dce3f37..adb5af5 100644 --- a/app/WebSocketApp.hs +++ b/app/WebSocketApp.hs @@ -77,6 +77,7 @@ clientLogic conn sessionStateMVar = do hPrint stderr msg ) -- the next line is a bit ugly, maybe there is a better way? + -- maybe refactor, so that the request Handler can choose to lock or not. -- TODO (\request -> modifyMVar_ sessionStateMVar (\sessionState -> requestHandler conn sessionState request)) (decodeStrict msg :: Maybe TL.JSONRequest) clientLogic conn sessionStateMVar @@ -102,7 +103,7 @@ requestHandler conn (tl, pl, cls, sem) (TL.InitializeTickLeisteR preTickLeiste) -- TODO -- Also TickLeisteR must be inside the modifyMVar, because we use the MVar also as a lock, and we can't --- have changes between reading the TickLeiste and sending it. +-- have changes between reading the TickLeiste and sending the information. requestHandler conn ss@(tl, pl, cls, sem) TL.TickLeisteR = do sendClientEvent (TL.InitializeTickLeisteE $ tickLeisteToPlayerList pl tl) conn return ss diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..89544a0 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./app/" + component: "tickLeisteServer:exe:tickLeisteServer" + - path: "./test/" + component: "tickLeisteServer:test:tickLeisteServer-test" diff --git a/package.yaml b/package.yaml index 3385bde..9d3610e 100644 --- a/package.yaml +++ b/package.yaml @@ -27,15 +27,15 @@ flags: https: description: Build with https support manual: true - default: false + default: true fast-cgi: description: Build with fastcgi support -- this depends on the fcgi c library manual: true - default: false + default: true cgi: description: Build with cgi support manual: true - default: false + default: true dependencies: - base >= 4.7 && < 5 @@ -50,6 +50,9 @@ dependencies: - wai - wai-websockets - http-types +- tomland +- validation-selective +- optparse-applicative when: - condition: flag(http) diff --git a/stack.yaml b/stack.yaml index 19abca3..340af4e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -47,6 +47,12 @@ extra-deps: # Override default flag values for local packages and extra-deps # flags: {} +flags: + tickLeisteServer: + http: true + https: true + fast-cgi: true + cgi: true # Extra package databases containing global packages # extra-package-dbs: [] diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 22b02d7..b948254 100644 --- a/tickLeisteServer.cabal +++ b/tickLeisteServer.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -26,12 +26,12 @@ source-repository head flag cgi description: Build with cgi support manual: True - default: False + default: True flag fast-cgi description: Build with fastcgi support -- this depends on the fcgi c library manual: True - default: False + default: True flag http description: Build with http support @@ -41,11 +41,17 @@ flag http flag https description: Build with https support manual: True - default: False + default: True executable tickLeisteServer main-is: Main.hs other-modules: + Backend.Backend + Backend.CGI + Backend.FastCGI + Backend.Http + Backend.Https + Config WaiApp WebSocketApp Paths_tickLeisteServer @@ -60,10 +66,13 @@ executable tickLeisteServer , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson + , tomland , uuid + , validation-selective , wai , wai-websockets , websockets @@ -106,11 +115,14 @@ test-suite tickLeisteServer-test , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson , tickLeisteServer + , tomland , uuid + , validation-selective , wai , wai-websockets , websockets