Decouple HealthCheck intervals

config/settings.yml

@@ -30,9 +30,14 @@ session-timeout: 7200
 jwt-expiration: 604800
 jwt-encoding: HS256
 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
-health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller
+health-check-interval:
-health-check-http: "_env:HEALTHCHECK_HTTP:true"
+  matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
+  http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
+  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
+  smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
+  widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
 health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
+health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"

package.yaml

@@ -126,6 +126,7 @@ dependencies:
   - streaming-commons
   - hourglass
   - unix
+  - stm-delay
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -19,7 +19,7 @@ module Application
 import Control.Monad.Logger                 (liftLoc, LoggingT(..), MonadLoggerIO(..))
 import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                              pgPoolSize, runSqlPool)
-import Import
+import Import                        hiding (cancel)
 import Language.Haskell.TH.Syntax           (qLocation)
 import Network.Wai (Middleware)
 import Network.Wai.Handler.Warp             (Settings, defaultSettings,
@@ -75,17 +75,22 @@ import System.Exit
 import qualified Database.Memcached.Binary.IO as Memcached
 
 import qualified System.Systemd.Daemon as Systemd
-import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
+import Control.Concurrent.Async.Lifted.Safe
 import System.Environment (lookupEnv)
 import System.Posix.Process (getProcessID)
 import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
 import qualified System.Posix.Signals as Signals (Handler(..))
 
-import Control.Monad.Trans.State (execStateT)
-
 import Network (socketPort)
 import qualified Network.Socket as Socket (close)
 
+import Control.Concurrent.STM.Delay
+import Control.Monad.STM (retry)
+
+import qualified Data.Set as Set
+
+import Data.Semigroup (Max(..), Min(..))
+
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
@@ -152,7 +157,7 @@ makeFoundation appSettings'@AppSettings{..} = do
 
     appJobCtl <- liftIO $ newTVarIO Map.empty
     appCronThread <- liftIO newEmptyTMVarIO
-    appHealthReport <- liftIO $ newTVarIO Nothing
+    appHealthReport <- liftIO $ newTVarIO Set.empty
 
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
@@ -333,7 +338,12 @@ warpSettings foundation = defaultSettings
                             if
                               | foundation ^. _appHealthCheckDelayNotify
                                 -> void . fork $ do
-                                  atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd)
+                                  let activeChecks = Set.fromList universeF
+                                                   & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
+                                  atomically $ do
+                                    results <- readTVar $ foundation ^. _appHealthReport
+                                    guard $ activeChecks == Set.map (classifyHealthReport . snd) results
+                                    guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results
                                   notifyReady
                               | otherwise
                                 -> notifyReady
@@ -354,19 +364,8 @@ warpSettings foundation = defaultSettings
                            
 
 getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
-getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
+getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
-getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv
+getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv
-
-adjustSettings :: MonadIO m => AppSettings -> m AppSettings
-adjustSettings = execStateT $ do
-  watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
-  watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
-  myProcessID <- liftIO getProcessID
-  case watchdogMicroSec of
-    Just wInterval
-      | maybe True (== myProcessID) watchdogProcess
-        -> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
-    _other -> return ()
 
 -- | main function for use by yesod devel
 develMain :: IO ()
@@ -417,7 +416,38 @@ appMain = runResourceT $ do
         case didStore of
           Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
           Nothing -> forM_ sockets $ liftIO . Socket.close
-        liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal
+        liftIO $ throwTo mainThreadId ExitSuccess
+
+      watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
+      watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
+      myProcessID <- liftIO getProcessID
+      case watchdogMicroSec of
+        Just wInterval
+          | maybe True (== myProcessID) watchdogProcess
+            -> let notifyWatchdog :: IO ()
+                   notifyWatchdog = forever $ do
+                     d <- liftIO . newDelay . floor $ wInterval % 2
+
+                     status <- atomically $ asum
+                       [ Nothing <$ waitDelay d
+                       , Just <$> do
+                           results <- readTVar $ foundation ^. _appHealthReport
+                           case fromNullable results of
+                             Nothing -> retry
+                             Just rs -> return $ ofoldMap1 (Max *** Min . healthReportStatus) rs
+                       ]
+
+                     case status of
+                       Just (_, Min status') -> void . Systemd.notifyStatus . unpack $ toPathPiece status'
+                       Nothing -> return ()
+
+                     case status of
+                       Just (_, Min HealthSuccess)
+                         -> void Systemd.notifyWatchdog
+                       _other
+                         -> return ()
+                in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
+        _other -> return ()
 
       let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
       case sockets of

src/Data/Universe/Instances/Reverse/MonoTraversable.hs

@@ -0,0 +1,17 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.MonoTraversable
+  (
+  ) where
+
+import Data.Universe
+import Data.MonoTraversable
+
+import Data.Universe.Instances.Reverse 
+  
+
+type instance Element (a -> b) = b
+
+instance Finite a => MonoFoldable (a -> b)
+instance (Ord a, Finite a) => MonoTraversable (a -> b)
+  

src/Foundation.hs

@@ -130,7 +130,7 @@ data UniWorX = UniWorX
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
     , appJSONWebKeySet   :: Jose.JwkSet
-    , appHealthReport    :: TVar (Maybe (UTCTime, HealthReport))
+    , appHealthReport    :: TVar (Set (UTCTime, HealthReport))
     }
 
 makeLenses_ ''UniWorX

src/Handler/Health.hs

@@ -9,55 +9,71 @@ import Utils.Lens
 
 import qualified Data.UUID as UUID
 
+import Data.Semigroup (Min(..), Max(..))
+
+import qualified Data.Set as Set
+
+import Control.Concurrent.STM.Delay
+
 
 getHealthR :: Handler TypedContent
 getHealthR = do
-  healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
+  reportStore <- getsYesod appHealthReport
-  let
+  healthReports' <- liftIO $ readTVarIO reportStore
-    handleMissing = do
-      interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval
-      reportStore <- getsYesod appHealthReport
-      waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just)
-      case waitResult of
-        Left () -> fail "System is not generating HealthReports"
-        Right _ -> redirect HealthR
-  (lastUpdated, healthReport) <- maybe handleMissing return healthReport'
   interval <- getsYesod $ view _appHealthCheckInterval
-  instanceId <- getsYesod appInstanceID
 
-  setWeakEtagHashable (instanceId, lastUpdated)
+  case fromNullable healthReports' of
-  expiresAt $ interval `addUTCTime` lastUpdated
+    Nothing -> do
-  setLastModified lastUpdated
+      let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval
-  
+      delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6
-  let status 
+      waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
-        | HealthSuccess <- classifyHealthReport healthReport
+      case waitResult of
-        = ok200
+        Left False -> sendResponseStatus noContent204 ()
-        | otherwise
+        Left True  -> fail "System is not generating HealthReports"
-        = internalServerError500
+        Right _    -> redirect HealthR
-  sendResponseStatus status <=< selectRep $ do
+    Just healthReports -> do
-    provideRep . siteLayoutMsg MsgHealthReport $ do
+      let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
-      setTitleI MsgHealthReport
+          reportNextUpdate (lastCheck, classifyHealthReport -> kind)
-      let HealthReport{..} = healthReport
+            = fromMaybe 0 (interval kind) `addUTCTime` lastCheck
-      [whamlet|
+          Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports
-        $newline never
+      instanceId <- getsYesod appInstanceID
-        <dl .deflist>
+
-          <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+      setWeakEtagHashable (instanceId, lastUpdated)
-          <dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
+      expiresAt nextUpdate
-          $maybe httpReachable <- healthHTTPReachable
+      setLastModified lastUpdated
-            <dt .deflist__dt>_{MsgHealthHTTPReachable}
+
-            <dd .deflist__dd>#{boolSymbol httpReachable}
+      let status'
-          $maybe ldapAdmins <- healthLDAPAdmins
+            | HealthSuccess <- status
-            <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+            = ok200
-            <dd .deflist__dd>#{textPercent ldapAdmins}
+            | otherwise
-          $maybe smtpConnect <- healthSMTPConnect
+            = internalServerError500
-            <dt .deflist__dt>_{MsgHealthSMTPConnect}
+      sendResponseStatus status' <=< selectRep $ do
-            <dd .deflist__dd>#{boolSymbol smtpConnect}
+        provideRep . siteLayoutMsg MsgHealthReport $ do
-          $maybe widgetMemcached <- healthWidgetMemcached
+          setTitleI MsgHealthReport
-            <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+          [whamlet|
-            <dd .deflist__dd>#{boolSymbol widgetMemcached}
+            $newline never
-      |]
+            <dl .deflist>
-    provideJson healthReport
+              $forall (_, report) <- healthReports'
-    provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
+                $case report
+                  $of HealthMatchingClusterConfig passed
+                    <dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthHTTPReachable (Just passed)
+                    <dt .deflist__dt>_{MsgHealthHTTPReachable}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthLDAPAdmins (Just found)
+                    <dt .deflist__dt>_{MsgHealthLDAPAdmins}
+                    <dd .deflist__dd>#{textPercent found}
+                  $of HealthSMTPConnect (Just passed)
+                    <dt .deflist__dt>_{MsgHealthSMTPConnect}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthWidgetMemcached (Just passed)
+                    <dt .deflist__dt>_{MsgHealthWidgetMemcached}
+                    <dd .deflist__dd>#{boolSymbol passed}
+                  $of _
+          |]
+        provideJson healthReports
+        provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
 
 getInstanceR :: Handler TypedContent
 getInstanceR = do

src/Import/NoFoundation.hs

@@ -101,6 +101,8 @@ import Data.Ratio as Import ((%))
 
 import Network.Mime as Import
 
+import Data.Universe.Instances.Reverse.MonoTraversable ()
+
 
 import Control.Monad.Trans.RWS (RWST)
 

src/Jobs.hs

@@ -32,6 +32,7 @@ import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
 import Cron
 import qualified Data.HashMap.Strict as HashMap
 import Data.HashMap.Strict (HashMap)
+import qualified Data.Set as Set
 
 import qualified Data.List.NonEmpty as NonEmpty
 
@@ -51,8 +52,6 @@ import Data.Time.Zones
 
 import Control.Concurrent.STM (retry)
 
-import qualified System.Systemd.Daemon as Systemd
-
 
 import Jobs.Handler.SendNotification
 import Jobs.Handler.SendTestEmail
@@ -284,21 +283,19 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
       -- logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
         lift . void . flip swapTMVar newCTab =<< asks jobCrontab
-    handleCmd JobCtlGenerateHealthReport = do
+    handleCmd (JobCtlGenerateHealthReport kind) = do
       hrStorage <- getsYesod appHealthReport
-      newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport
+      newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind
 
-      $logInfoS "HealthReport" $ toPathPiece newStatus
+      $logInfoS (tshow kind) $ toPathPiece newStatus
       unless (newStatus == HealthSuccess) $ do
-        $logErrorS "HealthReport" $ tshow newReport
+        $logErrorS (tshow kind) $ tshow newReport
   
       liftIO $ do
         now <- getCurrentTime
-        atomically . writeTVar hrStorage $ Just (now, newReport)
+        let updateReports = Set.insert (now, newReport)
-        
+                          . Set.filter (((/=) `on` classifyHealthReport) newReport . snd)
-        void . Systemd.notifyStatus . unpack $ toPathPiece newStatus
+        atomically . modifyTVar' hrStorage $ force . updateReports
-        when (newStatus == HealthSuccess) $
-          void Systemd.notifyWatchdog
 
 jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
 jLocked jId act = do

src/Jobs/Crontab.hs

@@ -43,14 +43,17 @@ determineCrontab = execWriterT $ do
       , cronNotAfter = Right CronNotScheduled
       }
 
-  tell $ HashMap.singleton
+  tell . flip foldMap universeF $ \kind -> 
-    JobCtlGenerateHealthReport
+    case appHealthCheckInterval kind of
-    Cron
+      Just int -> HashMap.singleton
-      { cronInitial = CronAsap
+        (JobCtlGenerateHealthReport kind)
-      , cronRepeat = CronRepeatScheduled CronAsap
+        Cron
-      , cronRateLimit = appHealthCheckInterval
+          { cronInitial = CronAsap
-      , cronNotAfter = Right CronNotScheduled
+          , cronRepeat = CronRepeatScheduled CronAsap
-      }
+          , cronRateLimit = int
+          , cronNotAfter = Right CronNotScheduled
+          }
+      Nothing  -> mempty
 
   let
     sheetJobs (Entity nSheet Sheet{..}) = do

src/Jobs/HealthReport.hs

@@ -28,18 +28,13 @@ import qualified Network.HaskellNet.SMTP as SMTP
 import Data.Pool (withResource)
 
 
-generateHealthReport :: Handler HealthReport
+generateHealthReport :: HealthCheck -> Handler HealthReport
-generateHealthReport
+generateHealthReport = $(dispatchTH ''HealthCheck)
-  = runConcurrently $ HealthReport
-    <$> Concurrently matchingClusterConfig
-    <*> Concurrently httpReachable
-    <*> Concurrently ldapAdmins
-    <*> Concurrently smtpConnect
-    <*> Concurrently widgetMemcached
   
-matchingClusterConfig :: Handler Bool
+dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
 -- ^ Can the cluster configuration be read from the database and does it match our configuration?
-matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
+dispatchHealthCheckMatchingClusterConfig
+  = fmap HealthMatchingClusterConfig . runDB $ and <$> forM universeF clusterSettingMatches
   where
     clusterSettingMatches ClusterCryptoIDKey = do
       ourSetting <- getsYesod appCryptoIDKey
@@ -74,11 +69,11 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
         _other                 -> return Nothing
 
 
-httpReachable :: Handler (Maybe Bool)
+dispatchHealthCheckHTTPReachable :: Handler HealthReport
-httpReachable = do
+dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
   staticAppRoot <- getsYesod $ view _appRoot
   doHTTP <- getsYesod $ view _appHealthCheckHTTP
-  for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do
+  for (staticAppRoot <* guard doHTTP) $ \_ -> do
     url <- getUrlRender <*> pure InstanceR
     baseRequest <- HTTP.parseRequest $ unpack url
     httpManager <- getsYesod appHttpManager
@@ -88,8 +83,8 @@ httpReachable = do
     getsYesod $ (== clusterId) . appClusterID
 
 
-ldapAdmins :: Handler (Maybe Rational)
+dispatchHealthCheckLDAPAdmins :: Handler HealthReport
-ldapAdmins = do
+dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do
   ldapPool' <- getsYesod appLdapPool
   ldapConf' <- getsYesod $ view _appLdapConf
   ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
@@ -109,8 +104,8 @@ ldapAdmins = do
     _other -> return Nothing
 
 
-smtpConnect :: Handler (Maybe Bool)
+dispatchHealthCheckSMTPConnect :: Handler HealthReport
-smtpConnect = do
+dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do
   smtpPool <- getsYesod appSmtpPool
   for smtpPool . flip withResource $ \smtpConn -> do
     response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
@@ -121,8 +116,8 @@ smtpConnect = do
         return False
 
 
-widgetMemcached :: Handler (Maybe Bool)
+dispatchHealthCheckWidgetMemcached :: Handler HealthReport
-widgetMemcached = do
+dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
   memcachedConn <- getsYesod appWidgetMemcached
   for memcachedConn $ \_memcachedConn' -> do
     let ext = "bin"

src/Jobs/Types.hs

@@ -69,7 +69,7 @@ data JobCtl = JobCtlFlush
             | JobCtlPerform QueuedJobId
             | JobCtlDetermineCrontab
             | JobCtlQueue Job
-            | JobCtlGenerateHealthReport
+            | JobCtlGenerateHealthReport HealthCheck
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance Hashable JobCtl

src/Model/Types/Security.hs

@@ -60,10 +60,6 @@ import Data.Text.Metrics (damerauLevenshtein)
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
-import Data.Semigroup (Min(..))
-import Control.Monad.Trans.Writer (execWriter)
-import Control.Monad.Writer.Class (MonadWriter(..))
-
 
 ----
 -- Security, Authentification, Notification Stuff
@@ -361,28 +357,55 @@ type AuthLiteral = PredLiteral AuthTag
 type AuthDNF = PredDNF AuthTag
 
 
-data HealthReport = HealthReport
+data HealthCheck
-  { healthMatchingClusterConfig :: Bool
+  = HealthCheckMatchingClusterConfig
-    -- ^ Is the database-stored configuration we're running under still up to date?
+  | HealthCheckHTTPReachable
-  , healthHTTPReachable :: Maybe Bool
+  | HealthCheckLDAPAdmins
-    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
+  | HealthCheckSMTPConnect
-    --
+  | HealthCheckWidgetMemcached
-    -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-  , healthLDAPAdmins :: Maybe Rational
+instance Universe HealthCheck
-    -- ^ Proportion of school admins that could be found in LDAP
+instance Finite HealthCheck
-    --
+instance Hashable HealthCheck
-    -- Is `Nothing` if LDAP is not configured or no users are school admins
-  , healthSMTPConnect :: Maybe Bool
-    -- ^ Can we connect to the SMTP server and say @NOOP@?
-  , healthWidgetMemcached :: Maybe Bool
-    -- ^ Can we store values in memcached and retrieve them via HTTP?
-  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
+  { constructorTagModifier = camelToPathPiece' 2
+  } ''HealthCheck
+nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
+pathPieceJSONKey ''HealthCheck
+  
+data HealthReport
+  = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
+    -- ^ Is the database-stored configuration we're running under still up to date?
+    --
+    -- Also tests database connection as a side effect
+  | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
+    -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
+  | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
+    -- ^ Proportion of school admins that could be found in LDAP
+  | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
+    -- ^ Can we connect to the SMTP server and say @NOOP@?
+  | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
+    -- ^ Can we store values in memcached and retrieve them via HTTP?
+  deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
+
+instance NFData HealthReport
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
   , omitNothingFields  = True
+  , sumEncoding = TaggedObject "test" "result"
+  , tagSingleConstructors = True
   } ''HealthReport
 
+classifyHealthReport :: HealthReport -> HealthCheck
+classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
+classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
+classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
+classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
+classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
+
 -- | `HealthReport` classified (`classifyHealthReport`) by badness
 --
 -- > a < b = a `worseThan` b
@@ -400,12 +423,13 @@ deriveJSON defaultOptions
   } ''HealthStatus
 nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
 
-classifyHealthReport :: HealthReport -> HealthStatus
+healthReportStatus :: HealthReport -> HealthStatus
 -- ^ Classify `HealthReport` by badness
-classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
+healthReportStatus = \case
-  unless healthMatchingClusterConfig . tell $ Min HealthFailure
+  HealthMatchingClusterConfig       False  -> HealthFailure
-  unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
+  HealthHTTPReachable         (Just False) -> HealthFailure
-  unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
+  HealthLDAPAdmins            (Just prop )
-  unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
+    | prop <= 0                            -> HealthFailure
-  unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
+  HealthSMTPConnect           (Just False) -> HealthFailure 
-
+  HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
+  _other                                   -> maxBound -- Minimum badness

src/Settings.hs

@@ -118,9 +118,9 @@ data AppSettings = AppSettings
     , appJwtExpiration          :: Maybe NominalDiffTime
     , appJwtEncoding            :: JwtEncoding
     
-    , appHealthCheckInterval    :: NominalDiffTime
+    , appHealthCheckInterval    :: HealthCheck -> Maybe NominalDiffTime
-    , appHealthCheckHTTP        :: Bool
     , appHealthCheckDelayNotify :: Bool
+    , appHealthCheckHTTP        :: Bool
 
     , appInitialLogSettings     :: LogSettings
 
@@ -390,8 +390,8 @@ instance FromJSON AppSettings where
         appJwtEncoding            <- o .: "jwt-encoding"
 
         appHealthCheckInterval    <- o .:  "health-check-interval"
-        appHealthCheckHTTP        <- o .:  "health-check-http"
         appHealthCheckDelayNotify <- o .:  "health-check-delay-notify"
+        appHealthCheckHTTP        <- o .:  "health-check-http"
 
         appSessionTimeout         <- o .: "session-timeout"
 

src/Utils.hs

@@ -79,6 +79,8 @@ import Data.Time.Clock
 
 import Data.List.NonEmpty (NonEmpty, nonEmpty)
 
+import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -936,3 +938,13 @@ setLastModified lastModified = do
     precision = 1
 
     safeMethods = [ methodGet, methodHead, methodOptions ]
+
+--------------
+-- Lattices --
+--------------
+
+foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono
+foldJoin = foldr (\/) bottom
+
+foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
+foldMeet = foldr (/\) top

src/Utils/PathPiece.hs

@@ -5,6 +5,7 @@ module Utils.PathPiece
   , splitCamel
   , camelToPathPiece, camelToPathPiece'
   , tuplePathPiece
+  , pathPieceJSONKey
   ) where
 
 import ClassyPrelude.Yesod
@@ -22,6 +23,8 @@ import qualified Data.Map as Map
 import Numeric.Natural
 
 import Data.List (foldl)
+
+import Data.Aeson.Types
   
 
 finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
@@ -109,3 +112,13 @@ tuplePathPiece tupleDim = do
                          ]) []
       ]
     ]
+
+
+pathPieceJSONKey :: Name -> DecsQ
+-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance
+pathPieceJSONKey tName
+  = [d| instance ToJSONKey $(conT tName) where
+          toJSONKey = toJSONKeyText toPathPiece
+        instance FromJSONKey $(conT tName) where
+          fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t
+      |]