94 lines
3.8 KiB
Haskell
94 lines
3.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Main where
|
|
|
|
-- TODO:
|
|
-- We need some logic to compile with different backends. Right now we only
|
|
-- support warp. But a (fast) cgi backend would be nice too.
|
|
|
|
-- TODO:
|
|
-- We need some way too configure things, like the port we run on.
|
|
-- see Network.Wai.Handler.Warp.Settings and Network.Wai.Handler.Warp.runSettings
|
|
|
|
import qualified Network.Wai as Wai
|
|
import WaiApp
|
|
import UnliftIO.Concurrent
|
|
import Backend.Backend
|
|
import Options.Applicative
|
|
import Data.Maybe(fromMaybe)
|
|
import Environment
|
|
import Colog.Message
|
|
import Colog
|
|
|
|
-- 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
|
|
-- to make this more idiomatic we could define al lens. But for one modification?
|
|
let env = defaultEnv {logAction = filterBySeverity (fromMaybe defaultLogLevel (logSeverity options)) msgSeverity (logAction defaultEnv) }
|
|
runEnvM env $ do
|
|
waiApp <- waiApplication serverState
|
|
let backs = zipWith (runBackend waiApp) (backendOptions options) backends
|
|
waitFor' <- sequence backs
|
|
let waitFor = concat waitFor'
|
|
blockBackends waitFor
|
|
|
|
defaultLogLevel :: Severity
|
|
defaultLogLevel = Info
|
|
{-# INLINE defaultLogLevel #-}
|
|
|
|
blockBackends :: [MVar ()] -> EnvM ()
|
|
blockBackends = mapM_ takeMVar
|
|
|
|
data CommandLineOptions = CommandLineOptions {
|
|
backendOptions :: [Either (Maybe String) Bool],
|
|
logSeverity :: Maybe Severity
|
|
}
|
|
|
|
backendsParser :: Parser [Either (Maybe String) Bool]
|
|
backendsParser = combineParser (fmap backendToParser backends)
|
|
|
|
severityParser :: Parser (Maybe Severity)
|
|
severityParser = optional $ option (auto :: ReadM Severity) (long "logLevel" <> help "Sets the LogLevel" <> metavar "LogLevel")
|
|
|
|
parser :: Parser CommandLineOptions
|
|
parser = CommandLineOptions
|
|
<$> backendsParser
|
|
<*> severityParser
|
|
|
|
|
|
runBackend :: Wai.Application -> Either (Maybe String) Bool -> Backend -> EnvM [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 _ _ _ = logError "Backend and parser type don't match! THIS IS A BUG" >> return []
|
|
|
|
commandLineParser :: ParserInfo CommandLineOptions
|
|
commandLineParser = info (parser <**> helper)
|
|
( fullDesc
|
|
<> progDesc "a small tickLeiste Server to play Splittermond with your crew" )
|
|
|
|
backendToParser :: Backend -> BackendParserType
|
|
backendToParser (BackendWithConfig _ name desc) = Left $ optional (strOption (long name <> help desc <> metavar "ConfigFile"))
|
|
backendToParser (BackendWithoutConfig _ name desc) = Right $ switch (long name <> help desc)
|
|
|
|
type BackendParserType = Either (Parser (Maybe String)) (Parser Bool)
|
|
|
|
combineParser :: [BackendParserType] -> 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 [])
|