fix(watchdog): improve status&watchdog notification

src/Application.hs

@@ -84,12 +84,11 @@ import Network.Socket (socketPort, Socket, PortNumber)
 import qualified Network.Socket as Socket (close)
 
 import Control.Concurrent.STM.Delay
-import Control.Monad.STM (retry)
 import Control.Monad.Trans.Cont (runContT, callCC)
 
 import qualified Data.Set as Set
 
-import Data.Semigroup (Max(..), Min(..))
+import Data.Semigroup (Min(..))
 
 import qualified Prometheus.Metric.GHC as Prometheus
 import qualified Prometheus
@@ -481,39 +480,46 @@ appMain = runResourceT $ do
       case watchdogMicroSec of
         Just wInterval
           | maybe True (== myProcessID) watchdogProcess
-            -> let notifyWatchdog :: IO ()
+            -> let notifyWatchdog :: forall a. IO a
                    notifyWatchdog = runAppLoggingT foundation $ go Nothing
                      where
-                       go pStatus = do
+                       go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a
-                         d <- liftIO . newDelay . floor $ wInterval % 2
+                       go pResults = do
+                         let delay = floor $ wInterval % 2
+                         d <- liftIO $ newDelay delay
 
-                         status <- atomically $ asum
+                         $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..."
-                           [ Nothing <$ waitDelay d
+                         mResults <- atomically $ asum
-                           , Just <$> do
+                           [ pResults <$ waitDelay d
+                           , do
                                results <- readTVar $ foundation ^. _appHealthReport
-                               case fromNullable results of
+                               guardOn (pResults /= Just results) $ Just results
-                                 Nothing -> retry
-                                 Just rs -> do
-                                   let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
-                                   guard $ pStatus /= Just status
-                                   return status
                            ]
 
-                         case status of
+                         $logDebugS "Notify" "Checking for status/watchdog..."
-                           Just (_, Min status') -> do
+                         (*> go mResults) . void . runMaybeT $ do
-                             $logInfoS "NotifyStatus" $ toPathPiece status'
+                           results <- hoistMaybe mResults
-                             liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
-                           Nothing -> return ()
 
-                         case status of
+                           Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results
-                           Just (_, Min HealthSuccess) -> do
+                           $logInfoS "NotifyStatus" $ toPathPiece status
-                             $logInfoS "NotifyWatchdog" "Notify"
+                           liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status
-                             liftIO $ void Systemd.notifyWatchdog
-                           _other -> return ()
 
-                         go status
+                           now <- liftIO getCurrentTime
-                in void $ allocateLinkedAsync notifyWatchdog
+                           iforM_ (foundation ^. _appHealthCheckInterval) . curry $ \case
-        _other -> return ()
+                             (_, 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
+                in do
+                     $logDebugS "Notify" "Spawning notify thread..."
+                     void $ allocateLinkedAsync notifyWatchdog
+        _other -> $logWarnS "Notify" "Not sending notifications of status/poking watchdog"
 
       let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
       case sockets of

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

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Universe.Instances.Reverse.WithIndex
+  (
+  ) where
+
+import ClassyPrelude
+
+import Data.Universe
+import Control.Lens.Indexed
+
+import Data.Universe.Instances.Reverse ()
+
+import qualified Data.Map as Map
+
+
+instance Finite a => FoldableWithIndex a ((->) a) where
+  ifoldMap f g = fold [ f x (g x) | x <- universeF ]
+instance (Ord a, Finite a) => TraversableWithIndex a ((->) a) where
+  itraverse f g = (Map.!) . Map.fromList <$> sequenceA [ (x, ) <$> f x (g x) | x <- universeF ]

src/Import/NoModel.hs

@@ -142,6 +142,7 @@ import Text.Blaze.Instances as Import ()
 import Jose.Jwt.Instances as Import ()
 import Web.PathPieces.Instances as Import ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Data.Universe.Instances.Reverse.WithIndex ()
 import Database.Persist.Class.Instances as Import ()
 import Database.Persist.Types.Instances as Import ()
 import Data.UUID.Instances as Import ()