From 679fb7cf9b3913645d39522b7efc0506e36d2245 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Sun, 26 May 2019 13:09:12 +0200
Subject: [PATCH] Fix notification delay

---
 src/Application.hs | 47 ++++++++++++++++++++++++++--------------------
 1 file changed, 27 insertions(+), 20 deletions(-)

diff --git a/src/Application.hs b/src/Application.hs
index 8113f74f8..b0eddd7ec 100644
--- a/src/Application.hs
+++ b/src/Application.hs
@@ -425,29 +425,36 @@ appMain = runResourceT $ do
         Just wInterval
           | maybe True (== myProcessID) watchdogProcess
             -> let notifyWatchdog :: IO ()
-                   notifyWatchdog = runAppLoggingT foundation . forever $ do
-                     d <- liftIO . newDelay . floor $ wInterval % 2
+                   notifyWatchdog = runAppLoggingT foundation $ go Nothing
+                     where
+                       go pStatus = 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
-                       ]
+                         status <- atomically $ asum
+                           [ Nothing <$ waitDelay d
+                           , Just <$> do
+                               results <- readTVar $ foundation ^. _appHealthReport
+                               case fromNullable results of
+                                 Nothing -> retry
+                                 Just rs -> do
+                                   let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
+                                   guard $ maybe True (/= status) pStatus
+                                   return status
+                           ]
 
-                     case status of
-                       Just (_, Min status') -> do
-                         $logInfoS "NotifyStatus" $ toPathPiece status'
-                         liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
-                       Nothing -> return ()
+                         case status of
+                           Just (_, Min status') -> do
+                             $logInfoS "NotifyStatus" $ toPathPiece status'
+                             liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
+                           Nothing -> return ()
 
-                     case status of
-                       Just (_, Min HealthSuccess) -> do
-                         $logInfoS "NotifyWatchdog" "Notify"
-                         liftIO $ void Systemd.notifyWatchdog
-                       _other -> return ()
+                         case status of
+                           Just (_, Min HealthSuccess) -> do
+                             $logInfoS "NotifyWatchdog" "Notify"
+                             liftIO $ void Systemd.notifyWatchdog
+                           _other -> return ()
+
+                         go status
                 in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
         _other -> return ()