fix: more verbose watchdog notification failures
This commit is contained in:
Gregor Kleen
parent
0fc23aa047
commit
48028c4053
@ -89,6 +89,7 @@ import Control.Concurrent.STM.Delay
|
||||
import Control.Monad.Trans.Cont (runContT, callCC)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Handler.Utils.Routes (classifyHandler)
|
||||
|
||||
@ -144,6 +145,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
|
||||
makeFoundation :: (MonadResource m, MonadUnliftIO m, MonadCatch m) => AppSettings -> m UniWorX
|
||||
makeFoundation appSettings''@AppSettings{..} = do
|
||||
registerGHCMetrics
|
||||
registerHealthCheckInterval appHealthCheckInterval
|
||||
|
||||
-- Some basic initializations: HTTP connection manager, logger, and static
|
||||
-- subsite.
|
||||
@ -549,41 +551,46 @@ appMain = runResourceT $ do
|
||||
Just wInterval
|
||||
| maybe True (== myProcessID) watchdogProcess
|
||||
-> let notifyWatchdog :: forall a m'. ( MonadLogger m', MonadIO m') => m' a
|
||||
notifyWatchdog = go Nothing
|
||||
where
|
||||
go :: Maybe (Set (UTCTime, HealthReport)) -> m' a
|
||||
go pResults = do
|
||||
let delay = floor $ wInterval % 4
|
||||
d <- liftIO $ newDelay delay
|
||||
notifyWatchdog = forever' Nothing $ \pResults -> do
|
||||
let delay = floor $ wInterval % 4
|
||||
d <- liftIO $ newDelay delay
|
||||
|
||||
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
|
||||
mResults <- atomically $ asum
|
||||
[ pResults <$ waitDelay d
|
||||
, do
|
||||
results <- readTVar $ foundation ^. _appHealthReport
|
||||
guardOn (pResults /= Just results) $ Just results
|
||||
]
|
||||
|
||||
$logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
|
||||
mResults <- atomically $ asum
|
||||
[ pResults <$ waitDelay d
|
||||
, do
|
||||
results <- readTVar $ foundation ^. _appHealthReport
|
||||
guardOn (pResults /= Just results) $ Just results
|
||||
]
|
||||
$logDebugS "Notify" "Checking for status/watchdog..."
|
||||
mResults <$ do
|
||||
void . runMaybeT $ do
|
||||
results <- hoistMaybe mResults
|
||||
|
||||
$logDebugS "Notify" "Checking for status/watchdog..."
|
||||
(*> go mResults) . void . runMaybeT $ do
|
||||
results <- hoistMaybe mResults
|
||||
let latestResults = Map.fromListWith (flip const) $ Set.toAscList results
|
||||
Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus) <$> fromNullable latestResults
|
||||
$logInfoS "NotifyStatus" $ toPathPiece status
|
||||
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
|
||||
|
||||
Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
|
||||
$logInfoS "NotifyStatus" $ toPathPiece status
|
||||
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
|
||||
now <- liftIO getCurrentTime
|
||||
let missing = flip ifoldMap (foundation ^. _appHealthCheckInterval) $ \hc mInterval -> fromMaybe mempty $ do
|
||||
interval <- mInterval
|
||||
let lastSuccess = maybeMonoid mResults
|
||||
& Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
|
||||
& Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess)
|
||||
& Set.mapMonotonic (view _1)
|
||||
& Set.lookupMax
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
iforM_ (foundation ^. _appHealthCheckInterval) . curry $ \case
|
||||
(_, Nothing) -> return ()
|
||||
(hc, Just interval) -> do
|
||||
lastSuccess <- hoistMaybe $ results
|
||||
& Set.filter (\(_, rep) -> classifyHealthReport rep == hc)
|
||||
& Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess)
|
||||
& Set.mapMonotonic (view _1)
|
||||
& Set.lookupMax
|
||||
guard $ lastSuccess > addUTCTime (negate interval) now
|
||||
$logInfoS "NotifyWatchdog" "Notify"
|
||||
liftIO $ void Systemd.notifyWatchdog
|
||||
successIsCurrent = lastSuccess > Just (negate interval `addUTCTime` now)
|
||||
|
||||
return . guardMonoid (not successIsCurrent) $ Set.singleton hc
|
||||
|
||||
if | Set.null missing -> do
|
||||
$logInfoS "NotifyWatchdog" "Notify"
|
||||
liftIO $ void Systemd.notifyWatchdog
|
||||
| otherwise ->
|
||||
$logWarnS "NotifyWatchdog" $ "No notify; missing \n\t " <> tshow (toList missing) <> "\n\tin " <> tshow (toList <$> mResults)
|
||||
in do
|
||||
$logDebugS "Notify" "Spawning notify thread..."
|
||||
void $ allocateLinkedAsync notifyWatchdog
|
||||
|
||||
10
src/Utils.hs
10
src/Utils.hs
@ -463,6 +463,10 @@ guardMonoid True x = x
|
||||
assertMonoid :: Monoid m => (m -> Bool) -> m -> m
|
||||
assertMonoid f x = guardMonoid (f x) x
|
||||
|
||||
maybeMonoid :: Monoid m => Maybe m -> m
|
||||
-- ^ Identify `Nothing` with `mempty`
|
||||
maybeMonoid = maybe mempty id
|
||||
|
||||
------------
|
||||
-- Tuples --
|
||||
------------
|
||||
@ -933,6 +937,12 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
|
||||
= let (MkFixed micro :: Micro) = realToFrac timeoutLength
|
||||
in fromInteger micro
|
||||
|
||||
forever' :: Monad m
|
||||
=> a
|
||||
-> (a -> m a)
|
||||
-> m b
|
||||
forever' start cont = cont start >>= flip forever' cont
|
||||
|
||||
|
||||
--------------
|
||||
-- Foldable --
|
||||
|
||||
@ -5,6 +5,7 @@ module Utils.Metrics
|
||||
, registerGHCMetrics
|
||||
, observeHTTPRequestLatency
|
||||
, registerReadyMetric
|
||||
, registerHealthCheckInterval
|
||||
, withJobWorkerState
|
||||
, observeYesodCacheSize
|
||||
, observeFavouritesQuickActionsDuration
|
||||
@ -74,6 +75,17 @@ healthReportDuration = unsafeRegister . vector ("check", "status") $ histogram i
|
||||
"Duration of last health check performed by this Uni2work-instance"
|
||||
buckets = histogramBuckets 5e-6 100e-3
|
||||
|
||||
data HealthCheckInterval = MkHealthCheckInterval
|
||||
|
||||
healthCheckInterval :: (HealthCheck -> Maybe NominalDiffTime) -> Metric HealthCheckInterval
|
||||
healthCheckInterval hcInts = Metric $ return (MkHealthCheckInterval, collectHealthCheckInterval)
|
||||
where
|
||||
collectHealthCheckInterval = return . pure . SampleGroup info GaugeType $ do
|
||||
(hc, Just int) <- itoList hcInts
|
||||
return . Sample "uni2work_health_check_interval_seconds" [("check", toPathPiece hc)] . encodeUtf8 $ tshow (realToFrac int :: Nano)
|
||||
info = Info "uni2work_health_check_interval_seconds"
|
||||
"Target interval at which health checks are executed by this Uni2work-instance"
|
||||
|
||||
{-# NOINLINE httpRequestLatency #-}
|
||||
httpRequestLatency :: Vector Label3 Histogram
|
||||
httpRequestLatency = unsafeRegister . vector ("handler", "method", "status") $ histogram info buckets
|
||||
@ -219,9 +231,9 @@ missingFiles = unsafeRegister . vector "ref" $ gauge info
|
||||
|
||||
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
|
||||
withHealthReportMetrics act = do
|
||||
before <- liftIO $ getTime Monotonic
|
||||
before <- liftIO getPOSIXTime
|
||||
report <- act
|
||||
after <- liftIO $ getTime Monotonic
|
||||
after <- liftIO getPOSIXTime
|
||||
|
||||
let checkVal = toPathPiece $ classifyHealthReport report
|
||||
statusVal = toPathPiece $ healthReportStatus report
|
||||
@ -258,6 +270,9 @@ observeHTTPRequestLatency classifyHandler app req respond' = do
|
||||
registerReadyMetric :: MonadIO m => m ()
|
||||
registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime
|
||||
|
||||
registerHealthCheckInterval :: MonadIO m => (HealthCheck -> Maybe NominalDiffTime) -> m ()
|
||||
registerHealthCheckInterval = liftIO . void . register . healthCheckInterval
|
||||
|
||||
classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4
|
||||
classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob)
|
||||
where
|
||||
|
||||
Reference in New Issue
Block a user