Skip to content
This repository has been archived by the owner on Aug 18, 2020. It is now read-only.

Commit

Permalink
[CBR-427] Make NtpCheck non-blocking unless explicitly forced
Browse files Browse the repository at this point in the history
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).
  • Loading branch information
KtorZ committed Sep 13, 2018
1 parent 53097d2 commit 803023a
Showing 1 changed file with 47 additions and 15 deletions.
62 changes: 47 additions & 15 deletions src/Cardano/Wallet/Kernel/NodeStateAdaptor.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.Wallet.Kernel.NodeStateAdaptor (
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 803023a

Please sign in to comment.