From 15bb52d6e5eed9c2531d7ac733034d37f61809c8 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 6 Aug 2018 16:07:41 +0200
Subject: [PATCH] Minor settings cleanup

---
 config/settings.yml |  4 +---
 src/Foundation.hs   |  5 +----
 src/Settings.hs     | 24 +++++++++++++++++++-----
 src/Utils.hs        |  5 +++++
 4 files changed, 26 insertions(+), 12 deletions(-)

diff --git a/config/settings.yml b/config/settings.yml
index 6e77b339d..21630d7db 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -10,11 +10,9 @@ ip-from-header: "_env:IP_FROM_HEADER:false"
 # Uncomment to set an explicit approot
 approot:        "_env:APPROOT:http://localhost:3000"
 
-# Optional values with the following production defaults.
-# In development, they default to the inverse.
-#
 detailed-logging: "_env:DETAILED_LOGGING:false"
 should-log-all: "_env:LOG_ALL:false"
+minimum-log-level: "_env:LOGLEVEL:warn"
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 45ca5f47b..a28faf0ed 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -644,10 +644,7 @@ instance Yesod UniWorX where
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
-    shouldLog app _source level =
-        appShouldLogAll (appSettings app)
-            || level == LevelWarn
-            || level == LevelError
+    shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
 
     makeLogger = return . appLogger
 
diff --git a/src/Settings.hs b/src/Settings.hs
index 33e0a8242..ce68f6a75 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
+import Utils
+import Control.Lens
+
+import Data.Maybe (fromJust)
+import qualified Data.Char as Char
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -68,12 +74,13 @@ data AppSettings = AppSettings
     -- ^ Indicate if auth dummy login should be enabled.
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
+    , appAuthPWFile             :: Maybe FilePath
+    -- ^ If set authenticate against a local password file
+    , appMinimumLogLevel        :: LogLevel
 
     , appUserDefaults           :: UserDefaultConf
 
     , appCryptoIDKeyFile        :: FilePath
-    , appAuthPWFile             :: Maybe FilePath
-    -- ^ If set authenticate against a local password file
     }
 
 data UserDefaultConf = UserDefaultConf
@@ -123,6 +130,13 @@ instance FromJSON LdapConf where
         ldapTimeout <- o .: "timeout"
         return LdapConf{..}
 
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
+    , sumEncoding = UntaggedValue
+    }
+  ''LogLevel
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -136,7 +150,7 @@ instance FromJSON AppSettings where
         let nonEmptyHost LdapConf{..} = case ldapHost of
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host
-        appLdapConf               <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
+        appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
@@ -144,18 +158,18 @@ instance FromJSON AppSettings where
 
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
+        appMinimumLogLevel        <- o .:  "minimum-log-level"
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
         appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
+        appAuthPWFile             <- assertM (not . null) <$> o .:? "auth-pwfile"
 
         appUserDefaults           <- o .:  "user-defaults"
 
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 
-        appAuthPWFile             <- ((\f -> f <$ guard (not $ null f)) =<<) <$> o .:? "auth-pwfile"
-
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and
diff --git a/src/Utils.hs b/src/Utils.hs
index 9f70d3159..5052406c0 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -302,6 +302,11 @@ shortCircuitM sc mx my op = do
 guardM :: MonadPlus m => m Bool -> m ()
 guardM f = guard =<< f
 
+assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
+assertM f x = do
+  x' <- x
+  x' <$ guard (f x')
+
 -- Some Utility Functions from Agda.Utils.Monad
 -- | Monadic if-then-else.
 ifM :: Monad m => m Bool -> m a -> m a -> m a