diff --git a/config/settings.yml b/config/settings.yml index 049692e5b..edd971e64 100644 --- a/config/settings.yml +++ b/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-http: "_env:HEALTHCHECK_HTTP:true" +health-check-interval: + 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" diff --git a/package.yaml b/package.yaml index 417b74e26..b9561aa88 100644 --- a/package.yaml +++ b/package.yaml @@ -126,6 +126,7 @@ dependencies: - streaming-commons - hourglass - unix + - stm-delay other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index b39657de7..a4112003d 100644 --- a/src/Application.hs +++ b/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 -getAppSettings = liftIO $ adjustSettings =<< 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 () +getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv +getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv -- | 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 diff --git a/src/Data/Universe/Instances/Reverse/MonoTraversable.hs b/src/Data/Universe/Instances/Reverse/MonoTraversable.hs new file mode 100644 index 000000000..aaa50ca73 --- /dev/null +++ b/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) + diff --git a/src/Foundation.hs b/src/Foundation.hs index 8fb2ec86e..b3826a51a 100644 --- a/src/Foundation.hs +++ 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 diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 872ab3410..046c16aff 100644 --- a/src/Handler/Health.hs +++ b/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 - let - 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' + reportStore <- getsYesod appHealthReport + healthReports' <- liftIO $ readTVarIO reportStore interval <- getsYesod $ view _appHealthCheckInterval - instanceId <- getsYesod appInstanceID - setWeakEtagHashable (instanceId, lastUpdated) - expiresAt $ interval `addUTCTime` lastUpdated - setLastModified lastUpdated - - let status - | HealthSuccess <- classifyHealthReport healthReport - = ok200 - | otherwise - = internalServerError500 - sendResponseStatus status <=< selectRep $ do - provideRep . siteLayoutMsg MsgHealthReport $ do - setTitleI MsgHealthReport - let HealthReport{..} = healthReport - [whamlet| - $newline never -
-
_{MsgHealthMatchingClusterConfig} -
#{boolSymbol healthMatchingClusterConfig} - $maybe httpReachable <- healthHTTPReachable -
_{MsgHealthHTTPReachable} -
#{boolSymbol httpReachable} - $maybe ldapAdmins <- healthLDAPAdmins -
_{MsgHealthLDAPAdmins} -
#{textPercent ldapAdmins} - $maybe smtpConnect <- healthSMTPConnect -
_{MsgHealthSMTPConnect} -
#{boolSymbol smtpConnect} - $maybe widgetMemcached <- healthWidgetMemcached -
_{MsgHealthWidgetMemcached} -
#{boolSymbol widgetMemcached} - |] - provideJson healthReport - provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport + case fromNullable healthReports' of + Nothing -> do + let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval + delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6 + waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) + case waitResult of + Left False -> sendResponseStatus noContent204 () + Left True -> fail "System is not generating HealthReports" + Right _ -> redirect HealthR + Just healthReports -> do + let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports + reportNextUpdate (lastCheck, classifyHealthReport -> kind) + = fromMaybe 0 (interval kind) `addUTCTime` lastCheck + Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports + instanceId <- getsYesod appInstanceID + + setWeakEtagHashable (instanceId, lastUpdated) + expiresAt nextUpdate + setLastModified lastUpdated + + let status' + | HealthSuccess <- status + = ok200 + | otherwise + = internalServerError500 + sendResponseStatus status' <=< selectRep $ do + provideRep . siteLayoutMsg MsgHealthReport $ do + setTitleI MsgHealthReport + [whamlet| + $newline never +
+ $forall (_, report) <- healthReports' + $case report + $of HealthMatchingClusterConfig passed +
_{MsgHealthMatchingClusterConfig} +
#{boolSymbol passed} + $of HealthHTTPReachable (Just passed) +
_{MsgHealthHTTPReachable} +
#{boolSymbol passed} + $of HealthLDAPAdmins (Just found) +
_{MsgHealthLDAPAdmins} +
#{textPercent found} + $of HealthSMTPConnect (Just passed) +
_{MsgHealthSMTPConnect} +
#{boolSymbol passed} + $of HealthWidgetMemcached (Just passed) +
_{MsgHealthWidgetMemcached} +
#{boolSymbol passed} + $of _ + |] + provideJson healthReports + provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports getInstanceR :: Handler TypedContent getInstanceR = do diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 975ae3925..7043c799e 100644 --- a/src/Import/NoFoundation.hs +++ b/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) diff --git a/src/Jobs.hs b/src/Jobs.hs index efbe126b6..5ba9f1fa4 100644 --- a/src/Jobs.hs +++ b/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) - - void . Systemd.notifyStatus . unpack $ toPathPiece newStatus - when (newStatus == HealthSuccess) $ - void Systemd.notifyWatchdog + let updateReports = Set.insert (now, newReport) + . Set.filter (((/=) `on` classifyHealthReport) newReport . snd) + atomically . modifyTVar' hrStorage $ force . updateReports jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a jLocked jId act = do diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index fac38ae52..aecca927e 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -43,14 +43,17 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } - tell $ HashMap.singleton - JobCtlGenerateHealthReport - Cron - { cronInitial = CronAsap - , cronRepeat = CronRepeatScheduled CronAsap - , cronRateLimit = appHealthCheckInterval - , cronNotAfter = Right CronNotScheduled - } + tell . flip foldMap universeF $ \kind -> + case appHealthCheckInterval kind of + Just int -> HashMap.singleton + (JobCtlGenerateHealthReport kind) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = int + , cronNotAfter = Right CronNotScheduled + } + Nothing -> mempty let sheetJobs (Entity nSheet Sheet{..}) = do diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index a8f6a0ff4..45500a8bb 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -28,18 +28,13 @@ import qualified Network.HaskellNet.SMTP as SMTP import Data.Pool (withResource) -generateHealthReport :: Handler HealthReport -generateHealthReport - = runConcurrently $ HealthReport - <$> Concurrently matchingClusterConfig - <*> Concurrently httpReachable - <*> Concurrently ldapAdmins - <*> Concurrently smtpConnect - <*> Concurrently widgetMemcached +generateHealthReport :: HealthCheck -> Handler HealthReport +generateHealthReport = $(dispatchTH ''HealthCheck) -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) -httpReachable = do +dispatchHealthCheckHTTPReachable :: Handler HealthReport +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) -ldapAdmins = do +dispatchHealthCheckLDAPAdmins :: Handler HealthReport +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) -smtpConnect = do +dispatchHealthCheckSMTPConnect :: Handler HealthReport +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) -widgetMemcached = do +dispatchHealthCheckWidgetMemcached :: Handler HealthReport +dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do memcachedConn <- getsYesod appWidgetMemcached for memcachedConn $ \_memcachedConn' -> do let ext = "bin" diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f333f0c7d..3522ff802 100644 --- a/src/Jobs/Types.hs +++ b/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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 27be35f81..04aad122b 100644 --- a/src/Model/Types/Security.hs +++ b/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 - { healthMatchingClusterConfig :: Bool - -- ^ Is the database-stored configuration we're running under still up to date? - , healthHTTPReachable :: Maybe Bool - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - -- - -- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings - , healthLDAPAdmins :: Maybe Rational - -- ^ Proportion of school admins that could be found in LDAP - -- - -- 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) +data HealthCheck + = HealthCheckMatchingClusterConfig + | HealthCheckHTTPReachable + | HealthCheckLDAPAdmins + | HealthCheckSMTPConnect + | HealthCheckWidgetMemcached + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe HealthCheck +instance Finite HealthCheck +instance Hashable HealthCheck 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 - unless healthMatchingClusterConfig . tell $ Min HealthFailure - unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure - unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure - unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure - unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure - +healthReportStatus = \case + HealthMatchingClusterConfig False -> HealthFailure + HealthHTTPReachable (Just False) -> HealthFailure + HealthLDAPAdmins (Just prop ) + | prop <= 0 -> HealthFailure + HealthSMTPConnect (Just False) -> HealthFailure + HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + _other -> maxBound -- Minimum badness diff --git a/src/Settings.hs b/src/Settings.hs index a60b4597b..ce28237a3 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -118,9 +118,9 @@ data AppSettings = AppSettings , appJwtExpiration :: Maybe NominalDiffTime , appJwtEncoding :: JwtEncoding - , appHealthCheckInterval :: NominalDiffTime - , appHealthCheckHTTP :: Bool + , appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime , 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" diff --git a/src/Utils.hs b/src/Utils.hs index 4f9d28a25..81f08b684 100644 --- a/src/Utils.hs +++ b/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 diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index c7434b54f..2d9b8b860 100644 --- a/src/Utils/PathPiece.hs +++ b/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 + |]