From 48028c40532577f74430340ed924af7116b8bd96 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Jan 2021 20:14:54 +0100 Subject: [PATCH] fix: more verbose watchdog notification failures --- src/Application.hs | 69 ++++++++++++++++++++++++-------------------- src/Utils.hs | 10 +++++++ src/Utils/Metrics.hs | 19 ++++++++++-- 3 files changed, 65 insertions(+), 33 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 831ed128f..38c23b6f0 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 0302d34c9..e08484afb 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index f8b21dad5..174a74cde 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -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