From 803023a860d7897da37c9bdc129bff4d3608a0a3 Mon Sep 17 00:00:00 2001
From: KtorZ <matthias.benkort@gmail.com>
Date: Thu, 13 Sep 2018 07:07:32 +0200
Subject: [PATCH] [CBR-427] Make NtpCheck non-blocking unless explicitly forced

When implementing the new data-layer 'node-info' handler, we've made the
choice to have the underlying check for NtpStatus blocking /
synchronous. This choices is usually fine as the check normally takes
around ~100ms. However, when running on CI, we do not connect to the
Internet and therefore, will always timeout for those check.  This could
be the cause for the integration tests bootstrap not syncing properly
(not telling us about it).
---
 src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs | 62 ++++++++++++++-----
 1 file changed, 47 insertions(+), 15 deletions(-)

diff --git a/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs b/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs
index b202e3bbe4c..04d17e882ab 100644
--- a/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs
+++ b/src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE ConstraintKinds            #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE RankNTypes                 #-}
 
 module Cardano.Wallet.Kernel.NodeStateAdaptor (
@@ -488,28 +489,59 @@ waitForUpdate = liftIO . takeMVar =<< asks l
     l :: Res -> MVar ConfirmedProposalState
     l = ucDownloadedUpdate . view lensOf'
 
+
 -- | Get the difference between NTP time and local system time, nothing if the
 -- NTP server couldn't be reached in the last 30min.
 --
 -- Note that one can force a new query to the NTP server in which case, it may
 -- take up to 30s to resolve.
-defaultGetNtpDrift :: MonadIO m => TVar NtpStatus -> V1.ForceNtpCheck -> m V1.TimeInfo
-defaultGetNtpDrift tvar ntpCheckBehavior = liftIO $ do
-    when (ntpCheckBehavior == V1.ForceNtpCheck) $
-        atomically $ writeTVar tvar NtpSyncPending
-    mkTimeInfo <$> waitForNtpStatus
+defaultGetNtpDrift
+    :: MonadIO m
+    => TVar NtpStatus
+    -> V1.ForceNtpCheck
+    -> m V1.TimeInfo
+defaultGetNtpDrift tvar ntpCheckBehavior = liftIO $ mkTimeInfo <$>
+    if (ntpCheckBehavior == V1.ForceNtpCheck) then
+        forceNtpCheck >> getNtpOffset blockingLookupNtpOffset
+    else
+        getNtpOffset nonBlockingLookupNtpOffset
   where
+    forceNtpCheck :: MonadIO m => m ()
+    forceNtpCheck =
+        atomically $ writeTVar tvar NtpSyncPending
+
+    getNtpOffset :: MonadIO m => (NtpStatus -> STM (Maybe NtpOffset)) -> m (Maybe NtpOffset)
+    getNtpOffset lookupNtpOffset =
+        atomically $ (readTVar tvar >>= lookupNtpOffset)
+
     mkTimeInfo :: Maybe NtpOffset -> V1.TimeInfo
-    mkTimeInfo = V1.TimeInfo . fmap (V1.mkLocalTimeDifference . toMicroseconds)
-
-    -- NOTE This usually takes ~100-300ms and at most 30s
-    waitForNtpStatus :: MonadIO m => m (Maybe NtpOffset)
-    waitForNtpStatus = atomically $ do
-        status <- readTVar tvar
-        case status of
-            NtpSyncPending     -> retry
-            NtpDrift offset    -> pure (Just offset)
-            NtpSyncUnavailable -> pure Nothing
+    mkTimeInfo =
+        V1.TimeInfo . fmap (V1.mkLocalTimeDifference . toMicroseconds)
+
+
+-- Lookup NtpOffset from an NTPStatus in a non-blocking manner
+--
+-- i.e. Returns immediately with 'Nothing' if the NtpSync is pending.
+nonBlockingLookupNtpOffset
+    :: NtpStatus
+    -> STM (Maybe NtpOffset)
+nonBlockingLookupNtpOffset = \case
+    NtpSyncPending     -> pure Nothing
+    NtpDrift offset    -> pure (Just offset)
+    NtpSyncUnavailable -> pure Nothing
+
+
+-- Lookup NtpOffset from an NTPStatus in a blocking manner, this usually
+-- take ~100ms
+--
+-- i.e. Wait (at most 30s) for the NtpSync to resolve if pending
+blockingLookupNtpOffset
+    :: NtpStatus
+    -> STM (Maybe NtpOffset)
+blockingLookupNtpOffset = \case
+    NtpSyncPending     -> retry
+    NtpDrift offset    -> pure (Just offset)
+    NtpSyncUnavailable -> pure Nothing
 
 
 -- | Get the most recent main block starting at the specified header