Merge branch 'configuration'

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
+  []

app/Backend/CGI.hs

@@ -0,0 +1,4 @@
+module Backend.CGI where
+
+
+

app/Backend/FastCGI.hs

@@ -0,0 +1 @@
+module Backend.FastCGI where

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

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

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

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 [])

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

hie.yaml

@@ -0,0 +1,6 @@
+cradle:
+  stack:
+    - path: "./app/"
+      component: "tickLeisteServer:exe:tickLeisteServer"
+    - path: "./test/"
+      component: "tickLeisteServer:test:tickLeisteServer-test"

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)

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: []

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