made loglevel configurable

app/Main.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 -- TODO:
@@ -13,7 +14,10 @@ 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
@@ -21,35 +25,58 @@ main :: IO ()
 main = do
   options <- execParser commandLineParser
   serverState <- newMVar newServerState
-  runEnvM defaultEnv $ do
+  -- 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) options backends
+    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 _   _                   _                            = error "Backend and parser type don't match! THIS IS A BUG"
+runBackend _   _                   _                            = logError "Backend and parser type don't match! THIS IS A BUG" >> return []
 
-commandLineParser :: ParserInfo [Either (Maybe String) Bool]
-commandLineParser = info (combineParser ( fmap backendToParser backends) <**> helper)
+commandLineParser :: ParserInfo CommandLineOptions
+commandLineParser = info (parser <**> helper)
   (  fullDesc
   <> progDesc "a small tickLeiste Server to play Splittermond with your crew" )
 
-backendToParser :: Backend -> ParserType
+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 ParserType = Either (Parser (Maybe String)) (Parser Bool)
+type BackendParserType = Either (Parser (Maybe String)) (Parser Bool)
 
-combineParser :: [ParserType] -> Parser [Either (Maybe String) 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