diff --git a/src/Application.hs b/src/Application.hs index b1f13b800..c7a8e046a 100644 --- a/src/Application.hs +++ b/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 - d <- liftIO . newDelay . floor $ wInterval % 2 + go :: Maybe (Set (UTCTime, HealthReport)) -> LoggingT IO a + go pResults = do + let delay = floor $ wInterval % 2 + d <- liftIO $ newDelay delay - status <- atomically $ asum - [ Nothing <$ waitDelay d - , Just <$> do + $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..." + mResults <- atomically $ asum + [ pResults <$ waitDelay d + , do results <- readTVar $ foundation ^. _appHealthReport - case fromNullable results of - Nothing -> retry - Just rs -> do - let status = ofoldMap1 (Max *** Min . healthReportStatus) rs - guard $ pStatus /= Just status - return status + guardOn (pResults /= Just results) $ Just results ] - case status of - Just (_, Min status') -> do - $logInfoS "NotifyStatus" $ toPathPiece status' - liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status' - Nothing -> return () + $logDebugS "Notify" "Checking for status/watchdog..." + (*> go mResults) . void . runMaybeT $ do + results <- hoistMaybe mResults - case status of - Just (_, Min HealthSuccess) -> do - $logInfoS "NotifyWatchdog" "Notify" - liftIO $ void Systemd.notifyWatchdog - _other -> return () + Min status <- hoistMaybe $ ofoldMap1 (Min . healthReportStatus . view _2) <$> fromNullable results + $logInfoS "NotifyStatus" $ toPathPiece status + liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status - go status - in void $ allocateLinkedAsync notifyWatchdog - _other -> return () + 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 + 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 diff --git a/src/Data/Universe/Instances/Reverse/WithIndex.hs b/src/Data/Universe/Instances/Reverse/WithIndex.hs new file mode 100644 index 000000000..ff6550058 --- /dev/null +++ b/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 ] diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 8b0082217..a49652b60 100644 --- a/src/Import/NoModel.hs +++ b/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 ()