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 index 9f8997f..cc600eb 100644 --- a/app/Backend/CGI.hs +++ b/app/Backend/CGI.hs @@ -1 +1,4 @@ module Backend.CGI where + + + diff --git a/app/Backend/Http.hs b/app/Backend/Http.hs index 52a58bb..3bedc98 100644 --- a/app/Backend/Http.hs +++ b/app/Backend/Http.hs @@ -5,21 +5,25 @@ module Backend.Http ( HttpConfiguration (..), httpDefaultSettings, httpDefaultSetting, - forkHttpBackend, + forkHttpBackend, -- key export httpConfigCodec, httpConfigsCodec, httpToWarpConfig, ) where -import Config +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 Network.Wai.Handler.Warp as HTTP +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 @@ -30,13 +34,23 @@ bindPreference :: Toml.Key -> TomlCodec BindPreference bindPreference = Toml.match _BindPreference data HttpConfiguration = HttpConfiguration - { instanceName :: T.Text, - port :: Int, - bindPref :: BindPreference + { 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 "http" 80 "*" +httpDefaultSetting = HttpConfiguration (setConfigM ("http" :: T.Text)) (setConfigM (80 :: Int)) (setConfigM ("*" :: BindPreference)) httpDefaultSettings :: [HttpConfiguration] httpDefaultSettings = [httpDefaultSetting] @@ -44,9 +58,9 @@ httpDefaultSettings = [httpDefaultSetting] httpConfigCodec :: TomlCodec HttpConfiguration httpConfigCodec = HttpConfiguration - <$> Toml.text "InstanceName" .= instanceName - <*> Toml.int "Port" .= port - <*> bindPreference "Bind" .= bindPref + <$> 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" @@ -55,7 +69,12 @@ 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 +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 +backend app config = HTTP.runSettings (httpToWarpConfig config) app diff --git a/app/Backend/Https.hs b/app/Backend/Https.hs index 77a2786..559d88f 100644 --- a/app/Backend/Https.hs +++ b/app/Backend/Https.hs @@ -3,7 +3,8 @@ module Backend.Https (forkHttpsBackend, httpsDefaultSettings) where import Backend.Http -import Config +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 @@ -15,16 +16,30 @@ import qualified Toml type HttpsConfiguration = (HttpConfiguration, TLSConfiguration) data TLSConfiguration = TLSConfiguration - { certFile :: FilePath, - certChain :: [FilePath], - keyFile :: FilePath + { 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 "certificate.pem" [] "key.pem" +tlsDefaultSetting = TLSConfiguration { + certFile = setConfigM "certificate.pem", + certChain = setConfigM [], + keyFile = setConfigM "key.pem" + } httpsDefaultSetting :: HttpsConfiguration -httpsDefaultSetting = (HttpConfiguration "https" 443 "*", tlsDefaultSetting) +httpsDefaultSetting = (HttpConfiguration (setConfigM "https") (setConfigM 443) (setConfigM "*"), tlsDefaultSetting) httpsDefaultSettings :: [HttpsConfiguration] httpsDefaultSettings = [httpsDefaultSetting] @@ -32,9 +47,9 @@ httpsDefaultSettings = [httpsDefaultSetting] httpsConfigCodec' :: TomlCodec TLSConfiguration httpsConfigCodec' = TLSConfiguration - <$> Toml.string "Certificate" .= certFile - <*> Toml.arrayOf Toml._String "CertChain" .= certChain - <*> Toml.string "KeyFile" .= keyFile + <$> 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' @@ -46,7 +61,13 @@ forkHttpsBackend :: Wai.Application -> FilePath -> IO [MVar ()] forkHttpsBackend app configFile = forkWithConfigs (backend app) httpsConfigsCodec configFile httpsToWarpTLSConfig :: HttpsConfiguration -> HTTPS.TLSSettings -httpsToWarpTLSConfig (_, tlsConfig) = HTTPS.tlsSettingsChain (certFile tlsConfig) (certChain tlsConfig) (keyFile tlsConfig) +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 diff --git a/app/Config.hs b/app/Config.hs index 71ae534..fcae9e3 100644 --- a/app/Config.hs +++ b/app/Config.hs @@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} -module Config(Configuration(..),forkBackend,withConfigs,forkWithConfigs) where - +module Config(forkBackend,withConfigs,forkWithConfigs,ConfigM,configM,getConfigM,setConfigM) where + +import Data.Semigroup + + import Toml (TomlCodec, (.=)) import qualified Toml import System.IO @@ -8,138 +11,26 @@ import qualified Data.Text as T import Control.Concurrent.MVar import Control.Concurrent import WaiApp +import Data.Maybe(fromJust) +import Data.Coerce --- this module should handle everything connected to our TOML config -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) -import Data.String -import qualified Network.Wai.Handler.Warp as HTTP -#endif -#ifdef HTTPS_SUPPORT -import qualified Network.Wai.Handler.WarpTLS as HTTPS -#endif +-- 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) -data Configuration = Configuration - { cppDummy :: () -- this is a hack to get around the , rules of haskell records and the preprocessor -#ifdef HTTP_SUPPORT - , httpConf :: [HttpConfiguration] -#endif -#ifdef HTTPS_SUPPORT - , httpsConf :: [(HttpConfiguration,HttpsConfiguration)] -#endif -#ifdef FASTCGI_SUPPORT - , fastCgiConf :: [FastCgiConfiguration] -#endif -#ifdef CGI_SUPPORT - , cgiConf :: [CgiConfiguration] -#endif - } +-- WARNING this function IS NOT total be sure the option is given! +getConfigM :: ConfigM a -> a +getConfigM = coerce . fromJust -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) --- 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 --- form -type BindPreference = String +setConfigM :: a -> ConfigM a +setConfigM = Just . coerce -_BindPreference :: Toml.TomlBiMap BindPreference Toml.AnyValue -_BindPreference = Toml._String - -bindPreference :: Toml.Key -> TomlCodec BindPreference -bindPreference = Toml.match _BindPreference - -data HttpConfiguration = HttpConfiguration - { port :: Int - , bindPref :: BindPreference - } -httpDefaultSettings :: HttpConfiguration -httpDefaultSettings = HttpConfiguration 80 "*" -#endif - -#ifdef HTTPS_SUPPORT -data HttpsConfiguration = HttpsConfiguration - { certFile :: FilePath - , certChain :: [FilePath] - , keyFile :: FilePath - } -httpsDefaultSettings :: HttpsConfiguration -httpsDefaultSettings = HttpsConfiguration "certificate.pem" [] "key.pem" -#endif - -#ifdef FASTCGI_SUPPORT -data FastCgiConfiguration = FastCgiConfiguration -#endif - -#ifdef CGI_SUPPORT -data CgiConfiguration = CgiConfiguration -#endif - -defaultConfiguration :: Configuration -defaultConfiguration = Configuration () -#ifdef HTTP_SUPPORT - [httpDefaultSettings] -#endif -#ifdef HTTPS_SUPPORT - [(httpDefaultSettings,httpsDefaultSettings)] -#endif -#ifdef FASTCGI_SUPPORT - [FastCgiConfiguration] -#endif -#ifdef CGI_SUPPORT - [CgiConfiguration] -#endif - -#if defined(HTTP_SUPPORT) || defined(HTTPS_SUPPORT) --- why a String? Why is the only way to generate a HostPreference by its IsString instance? --- why does warp not expose its constructors?? -httpConfigConstructor :: Int -> String -> HTTP.Settings -httpConfigConstructor port bind = HTTP.setPort port $ HTTP.setHost (fromString bind) HTTP.defaultSettings -httpConfigCodec :: TomlCodec HttpConfiguration -httpConfigCodec = HttpConfiguration - <$> Toml.int "Port" .= port - <*> bindPreference "Bind" .= bindPref -#endif - -#ifdef HTTPS_SUPPORT -httpsConfigCodec :: TomlCodec (HttpConfiguration,HttpsConfiguration) -httpsConfigCodec = Toml.pair httpConfigCodec httpsConfigCodec' - -httpsConfigCodec' :: TomlCodec HttpsConfiguration -httpsConfigCodec' = HttpsConfiguration --- the hardcoded strings are a bloody hack, but we can't extract the values back out of a config (they are there --- warp just doesn't export the neccesarry types). So we hardcode default values, which is kind of realy bad, but --- we don't need it in our usecase - <$> Toml.string "Certificate" .= certFile - <*> Toml.arrayOf Toml._String "CertChain" .= certChain - <*> Toml.string "KeyFile" .= keyFile -#endif - -#ifdef FASTCGI_SUPPORT -fastCgiConfigCodec :: TomlCodec FastCgiConfiguration -fastCgiConfigCodec = pure FastCgiConfiguration -#endif - -#ifdef CGI_SUPPORT -cgiConfigCodec :: TomlCodec CgiConfiguration -cgiConfigCodec = pure CgiConfiguration -#endif - -configurationCodec :: TomlCodec Configuration -configurationCodec = pure (Configuration ()) -#ifdef HTTP_SUPPORT - <*> Toml.list httpConfigCodec "http" .= httpConf -#endif -#ifdef HTTPS_SUPPORT - <*> Toml.list httpsConfigCodec "https" .= httpsConf -#endif -#ifdef FASTCGI_SUPPORT - <*> Toml.list fastCgiConfigCodec "fast-cgi" .= fastCgiConf -#endif -#ifdef CGI_SUPPORT - <*> Toml.list cgiConfigCodec "cgi" .= cgiConf -#endif +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 (\conf -> forkBackend $ f conf) +forkWithConfigs f = withConfigs (forkBackend . f) withConfigs :: (a -> IO (MVar ())) -> TomlCodec [a] -> FilePath -> IO [MVar ()] withConfigs f codec configFile = do diff --git a/app/Main.hs b/app/Main.hs index 5966cfa..e62bd02 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -9,8 +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 @@ -29,21 +32,51 @@ import qualified Network.Wai.Handler.FastCGI as FastCGI import qualified Network.Wai.Handler.CGI as CGI #endif --- we should add support for multiple backends (so we should fork them and --- then wait till all of them terminated) +-- 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/package.yaml b/package.yaml index c3bdb37..9d3610e 100644 --- a/package.yaml +++ b/package.yaml @@ -52,6 +52,7 @@ dependencies: - http-types - tomland - validation-selective +- optparse-applicative when: - condition: flag(http) diff --git a/tickLeisteServer.cabal b/tickLeisteServer.cabal index 8725117..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 @@ -46,6 +46,7 @@ flag https executable tickLeisteServer main-is: Main.hs other-modules: + Backend.Backend Backend.CGI Backend.FastCGI Backend.Http @@ -65,6 +66,7 @@ executable tickLeisteServer , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson @@ -113,6 +115,7 @@ test-suite tickLeisteServer-test , bytestring , containers , http-types + , optparse-applicative , text , tickLeiste , tickLeiste-aeson