Merge pull request #3323 from input-output-hk/coot/cdec-356

[CDEC-356] Forcable ntp check

Author: coot

networking/src/Ntp/Client.hs

@@ -21,9 +21,8 @@ module Ntp.Client
 import           Universum hiding (Last, catch)
 
 import           Control.Concurrent (threadDelay)
-import           Control.Concurrent.Async (async, cancel, concurrently_, race,
-                     withAsync)
-import           Control.Concurrent.STM (TVar, modifyTVar', retry)
+import           Control.Concurrent.Async (async, concurrently_, race)
+import           Control.Concurrent.STM (TVar, check, modifyTVar', retry)
 import           Control.Exception (Exception, IOException, catch, handle)
 import           Control.Monad (forever)
 import           Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON,
@@ -157,30 +156,25 @@ updateStatus cli = updateStatus' cli fn
 -- drift.
 sendLoop :: NtpClient -> [Addresses] -> IO ()
 sendLoop cli addrs = do
-
-
     let respTimeout = ntpResponseTimeout (ncSettings cli)
     let poll        = ntpPollDelay (ncSettings cli)
 
-    () <- withAsync
-        (do
-            -- wait for responses and update status
-            _ <- timeout respTimeout waitForResponses
-            updateStatus cli
-        )
-        (\a -> do
-            -- send packets and wait until end of poll delay
-            sock <- atomically $ readTVar $ ncSockets cli
-            pack <- mkNtpPacket
-            sendPacket sock pack addrs
-
-            threadDelay $ fromIntegral poll
-            cancel a
-        )
+    -- send packets and wait until end of poll delay
+    sock <- atomically $ readTVar $ ncSockets cli
+    pack <- mkNtpPacket
+    sendPacket sock pack addrs
+
+    _ <- timeout respTimeout waitForResponses
+    updateStatus cli
+    -- after @'updateStatus'@ @'ntpStatus'@ is guaranteed to be
+    -- different from @'NtpSyncPending'@, now we can wait until it was
+    -- changed back to @'NtpSyncPending'@ to force a request.
+    _ <- timeout poll waitForRequest
 
     -- reset state & status before next loop
     atomically $ writeTVar (ncState cli) []
     atomically $ writeTVar (ncStatus cli) NtpSyncPending
+
     sendLoop cli addrs
 
     where
@@ -192,6 +186,14 @@ sendLoop cli addrs = do
                     retry
             logDebug "collected all responses"
 
+        -- Wait for a request to force an ntp check.
+        waitForRequest =
+            atomically $ do
+                status <- readTVar $ ncStatus cli
+                check (status == NtpSyncPending)
+                return ()
+
+
 -- |
 -- Start listening for responses on the socket @'ncSockets'@
 startReceive :: NtpClient -> IO ()