fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Decouple HealthCheck intervals

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-24 22:24:48 +02:00
parent 0cabee0826
commit 30fe78ebdc
15 changed files with 253 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
config/settings.yml
View File

@ -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"

1
package.yaml
View File

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

70
src/Application.hs
View File

@ -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

17
src/Data/Universe/Instances/Reverse/MonoTraversable.hs Normal file
View File

@ -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)

2
src/Foundation.hs
View File

@ -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

104
src/Handler/Health.hs
View File

@ -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
<dl .deflist>
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
<dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
$maybe httpReachable <- healthHTTPReachable
<dt .deflist__dt>_{MsgHealthHTTPReachable}
<dd .deflist__dd>#{boolSymbol httpReachable}
$maybe ldapAdmins <- healthLDAPAdmins
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
<dd .deflist__dd>#{textPercent ldapAdmins}
$maybe smtpConnect <- healthSMTPConnect
<dt .deflist__dt>_{MsgHealthSMTPConnect}
<dd .deflist__dd>#{boolSymbol smtpConnect}
$maybe widgetMemcached <- healthWidgetMemcached
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
<dd .deflist__dd>#{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
<dl .deflist>
$forall (_, report) <- healthReports'
$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

2
src/Import/NoFoundation.hs
View File

@ -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)

19
src/Jobs.hs
View File

@ -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

19
src/Jobs/Crontab.hs
View File

@ -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

33
src/Jobs/HealthReport.hs
View File

@ -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"

2
src/Jobs/Types.hs
View File

@ -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

82
src/Model/Types/Security.hs
View File

@ -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

6
src/Settings.hs
View File

@ -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"

12
src/Utils.hs
View File

@ -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

13
src/Utils/PathPiece.hs
View File

@ -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
|]