Allow for limited wallclock rollback

ouroboros-consensus-test/src/Test/ThreadNet/Network.hs

@@ -97,6 +97,7 @@ import           Ouroboros.Consensus.Util.Orphans ()
 import           Ouroboros.Consensus.Util.RedundantConstraints
 import           Ouroboros.Consensus.Util.ResourceRegistry
 import           Ouroboros.Consensus.Util.STM
+import           Ouroboros.Consensus.Util.Time
 
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
 import           Ouroboros.Consensus.Storage.ChainDB.Impl (ChainDbArgs (..))
@@ -957,12 +958,10 @@ runThreadNetwork systemTime ThreadNetworkArgs
         , hfbtSystemTime     = OracularClock.finiteSystemTime clock
         , hfbtTracer         =
             contramap
-              (\(t, e) ->
-                 TraceCurrentSlotUnknown
-                   -- We don't really have a SystemStart in the tests
-                   (fromRelativeTime (SystemStart dawnOfTime) t)
-                   e)
+              -- We don't really have a SystemStart in the tests
+              (fmap (fromRelativeTime (SystemStart dawnOfTime)))
               (blockchainTimeTracer tracers)
+        , hfbtMaxClockRewind = secondsToNominalDiffTime 0
         }
 
       let kaRng = case seed of

ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs

@@ -30,6 +30,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
+import           Ouroboros.Consensus.Util.Time
 
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Orphans.IOLike ()
@@ -85,7 +86,7 @@ prop_delayNextSlot TestDelayIO{..} =
         tdioStart  <- pickSystemStart
         let time = defaultSystemTime tdioStart nullTracer
         atStart    <- fst <$> getWallClockSlot  time tdioSlotLen
-        nextSlot   <-         waitUntilNextSlot time tdioSlotLen atStart
+        nextSlot   <-         waitUntilNextSlot time tdioSlotLen maxClockRewind atStart
         afterDelay <- fst <$> getWallClockSlot  time tdioSlotLen
         assertEqual "atStart + 1" (atStart + 1) afterDelay
         assertEqual "nextSlot"    nextSlot      afterDelay
@@ -96,14 +97,20 @@ prop_delayNextSlot TestDelayIO{..} =
         pick :: UTCTime -> SystemStart
         pick = SystemStart . Time.addUTCTime (negate tdioStart')
 
+    -- Will only be needed when the system clock rolls back during the execution
+    -- of this test, which is rather unlikely.
+    maxClockRewind :: NominalDiffTime
+    maxClockRewind = secondsToNominalDiffTime 20
+
 {-------------------------------------------------------------------------------
   Test delay using mock time
 -------------------------------------------------------------------------------}
 
 -- | Schedule defines the system time as offsets (in seconds) from the start
 --
 -- We limit the resolution of the offsets to 0.1 seconds to make the tests
--- easier to interpret and shrink (slot length is set to 1 seconds).
+-- easier to interpret and shrink (slot length is set to 1 seconds). We allow
+-- the clock to go back at most 2 seconds.
 newtype Schedule = Schedule { getSchedule :: [Fixed E1] }
   deriving stock (Show)
   deriving NoThunks via AllowThunk Schedule
@@ -140,39 +147,52 @@ scheduleCountSkips (Schedule (t:ts)) = go t ts
 --
 -- Returns the set of slot numbers that 'BlockchainTime' should report or,
 -- if time moved backwards, the @(before, after)@ slot pair where @after@ is
--- (strictly) less than @before@.
+-- more than the @maxClockRewind@ less than @before@.
 --
--- NOTE: Assumes the slot length is 1 for these sets.
+-- NOTE: Assumes the slot length is 1 and max clock rewind is 2 for these sets.
 model :: Int -> Schedule -> Either (SlotNo, SlotNo) [SlotNo]
-model = \need (Schedule s) -> runExcept $ go need s (SlotNo 0)
+model = \need (Schedule ss) ->
+    -- Establish the invariant that the 'Schedule' is never empty
+    let ss' = case ss of
+          [] -> [0.0]
+          _  -> ss
+    in runExcept $
+      (SlotNo 0 :) <$> go (need - 1) (Schedule ss') (0.0, SlotNo 0)
   where
-    go :: Int        -- How many slots do we still need to collect?
-       -> [Fixed E1] -- Remaining schedule
-       -> SlotNo     -- Current slot
-       -> Except (SlotNo, SlotNo) [SlotNo]
-
-    -- No more slots required
-    go 0 _ _ =
-        return []
-
-    -- If we don't override the delays, everything just works as expected
-    go need [] now =
-        return [SlotNo (unSlotNo now + n) | n <- take need [0 ..]]
-
-    go need (s:ss) now
-      -- Time didn't actually move according to the schedule, 'BlockchainTime'
-      -- should wait until it does.
-      | now' == now = go need ss now
-
-      -- If time did move forward, 'BlockchainTime' should report the next slot
-      -- (which might not be the successor of the previous)
-      | now' >  now = (now :) <$> go (need - 1) ss now'
-
-      -- If time went backwards, we should see an exception
-      | otherwise   = throwError (now, now')
+    -- | This let's us treat the schedule as an infinite stream of offsets.
+    --
+    -- INVARIANT: 'Schedule' is never empty
+    --
+    -- When there is no offset after the current one in the schedule, create
+    -- one, exactly one slot length after the current one.
+    advanceSchedule :: Schedule -> (Fixed E1, Schedule)
+    advanceSchedule (Schedule ss) =
+        case ss of
+          []    -> error "invariant broken: empty schedule"
+          [s]   -> (s,   Schedule [s + 1.0])
+          s:ss' -> (s,   Schedule ss')
+
+    go ::
+         Int
+      -> Schedule
+      -> (Fixed E1, SlotNo)
+      -> Except (SlotNo, SlotNo) [SlotNo]
+    go n ss (prevOffset, prevSlot)
+        | n <= 0
+        = return []
+        | nextSlot == prevSlot
+        = go n ss' (offset, nextSlot)
+        | nextSlot >  prevSlot
+        = (nextSlot :) <$> go (n - 1) ss' (offset, nextSlot)
+        -- If time moved back, but less than 2s, we don't throw an exception
+        | prevOffset - offset < 2
+        = go n ss' (prevOffset, prevSlot)
+        -- If time moved back too much, we should see an exception
+        | otherwise
+        = throwError (prevSlot, nextSlot)
       where
-        now' :: SlotNo
-        now' = offsetToSlot s
+        (offset, ss') = advanceSchedule ss
+        nextSlot      = offsetToSlot offset
 
 instance Arbitrary Schedule where
   arbitrary =
@@ -187,6 +207,9 @@ instance Arbitrary Schedule where
               -- If time goes back too often, most runs end in an exception
               (100, (\delta -> now + fixedFromDeci delta) <$> choose (0, 30))
 
+              -- Go back a bit without exceeding the max clock rewind
+            , (10, (\delta -> max 0 (now - fixedFromDeci delta)) <$> choose (0, 2))
+
               -- Occassionally just pick an entirely random time
             , (1, fixedFromDeci <$> choose (0, 100))
             ]
@@ -230,7 +253,11 @@ prop_delayClockShift schedule =
 
     testResult :: Either Failure [SlotNo]
     testResult = overrideDelay dawnOfTime schedule $
-        testOverrideDelay (SystemStart dawnOfTime) (slotLengthFromSec 1) numSlots
+        testOverrideDelay
+          (SystemStart dawnOfTime)
+          (slotLengthFromSec 1)
+          (secondsToNominalDiffTime 2)
+          numSlots
 
     checkException :: SlotNo -> SlotNo -> SomeException -> Property
     checkException before after e
@@ -252,20 +279,26 @@ prop_delayNoClockShift =
     withMaxSuccess 1 $ ioProperty $ do
       now   <- getCurrentTime
       slots <- originalDelay $
-                 testOverrideDelay (SystemStart now) (slotLengthFromMillisec 100) 5
+                 testOverrideDelay
+                   (SystemStart now)
+                   (slotLengthFromMillisec 100)
+                   (secondsToNominalDiffTime 20)
+                   5
       assertEqual "slots" slots [SlotNo n | n <- [0..4]]
 
 testOverrideDelay :: forall m. (IOLike m, MonadTime m, MonadDelay (OverrideDelay m))
                   => SystemStart
                   -> SlotLength
+                  -> NominalDiffTime
                   -> Int  -- ^ Number of slots to collect
                   -> OverrideDelay m [SlotNo]
-testOverrideDelay systemStart slotLength numSlots = do
+testOverrideDelay systemStart slotLength maxClockRewind numSlots = do
     result <- withRegistry $ \registry -> do
       time <- simpleBlockchainTime
                 registry
                 (defaultSystemTime systemStart nullTracer)
                 slotLength
+                maxClockRewind
       slotsVar <- uncheckedNewTVarM []
       cancelCollection <-
         onKnownSlotChange registry time "testOverrideDelay" $ \slotNo ->

ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Default.hs

@@ -4,7 +4,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Default (
 
 import           Control.Monad
 import           Control.Tracer
-import           Data.Time (diffUTCTime)
+import           Data.Time (UTCTime, diffUTCTime)
 
 import           Control.Monad.Class.MonadTime (MonadTime (..))
 
@@ -15,7 +15,7 @@ import           Ouroboros.Consensus.Util.Time
 
 defaultSystemTime :: (MonadTime m, MonadDelay m)
                   => SystemStart
-                  -> Tracer m TraceBlockchainTimeEvent
+                  -> Tracer m (TraceBlockchainTimeEvent UTCTime)
                   -> SystemTime m
 defaultSystemTime start tracer = SystemTime {
       systemTimeCurrent = toRelativeTime start <$> getCurrentTime
@@ -25,7 +25,7 @@ defaultSystemTime start tracer = SystemTime {
 -- | Wait until system start if necessary
 waitForSystemStart :: (MonadTime m, MonadDelay m)
                    => SystemStart
-                   -> Tracer m TraceBlockchainTimeEvent
+                   -> Tracer m (TraceBlockchainTimeEvent UTCTime)
                    -> m ()
 waitForSystemStart start tracer = do
     now <- getCurrentTime

ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs

@@ -1,13 +1,12 @@
-{-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 
 module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork (
-    BackoffDelay (..),
-    HardForkBlockchainTimeArgs (..),
-    hardForkBlockchainTime,
+    BackoffDelay (..)
+  , HardForkBlockchainTimeArgs (..)
+  , hardForkBlockchainTime
   ) where
 
 import           Control.Monad
@@ -54,8 +53,18 @@ data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs
   , hfbtLedgerConfig   :: LedgerConfig blk
   , hfbtRegistry       :: ResourceRegistry m
   , hfbtSystemTime     :: SystemTime m
-  , hfbtTracer         :: Tracer m (RelativeTime, HF.PastHorizonException)
-    -- ^ Tracer used when current slot is unknown
+  , hfbtTracer         :: Tracer m (TraceBlockchainTimeEvent RelativeTime)
+  , hfbtMaxClockRewind :: NominalDiffTime
+    -- ^ Maximum time the clock can be rewound without throwing a fatal
+    -- 'SystemClockMovedBack' exception.
+    --
+    -- When the slot length is short, e.g., Praos' 1s compared to PBFT's 20s,
+    -- the chances of an NTP sync causing the clock to go back to the previous
+    -- slot increase.
+    --
+    -- We allow the system clock to rewind up to 'hfbtMaxClockRewind', tracing a
+    -- 'TraceSystemClockMovedBack' message in such cases. Note that the current
+    -- slot *never decreases*, we just wait a bit longer in the same slot.
   }
 
 -- | 'BlockchainTime' instance with support for the hard fork history
@@ -70,10 +79,10 @@ hardForkBlockchainTime args = do
     run <- HF.runWithCachedSummary (summarize <$> getLedgerState)
     systemTimeWait
 
-    (firstSlot, firstDelay) <- getCurrentSlot' tracer time run backoffDelay
+    (firstSlot, now, firstDelay) <- getCurrentSlot' tracer time run backoffDelay
     slotVar <- newTVarIO firstSlot
     void $ forkLinkedThread registry "hardForkBlockchainTime" $
-             loop run slotVar firstSlot firstDelay
+             loop run slotVar firstSlot now firstDelay
 
     return $ BlockchainTime {
         getCurrentSlot = readTVar slotVar
@@ -86,6 +95,7 @@ hardForkBlockchainTime args = do
       , hfbtRegistry       = registry
       , hfbtSystemTime     = time@SystemTime{..}
       , hfbtTracer         = tracer
+      , hfbtMaxClockRewind = maxClockRewind
       } = args
 
     summarize :: LedgerState blk -> HF.Summary (HardForkIndices blk)
@@ -94,57 +104,69 @@ hardForkBlockchainTime args = do
     loop :: HF.RunWithCachedSummary xs m
          -> StrictTVar m CurrentSlot
          -> CurrentSlot     -- Previous slot
+         -> RelativeTime    -- Current time
          -> NominalDiffTime -- Time to wait until next slot
          -> m Void
     loop run slotVar = go
       where
-        go :: CurrentSlot -> NominalDiffTime -> m Void
-        go prevSlot delay = do
+        go :: CurrentSlot -> RelativeTime -> NominalDiffTime -> m Void
+        go prevSlot prevTime delay = do
            threadDelay (nominalDelay delay)
-           (newSlot, newDelay) <- getCurrentSlot' tracer time run backoffDelay
-           checkValidClockChange (prevSlot, newSlot)
-           atomically $ writeTVar slotVar newSlot
-           go newSlot newDelay
+           (newSlot, newTime, newDelay) <- getCurrentSlot' tracer time run backoffDelay
+           newSlot' <- checkValidClockChange (prevSlot, prevTime) (newSlot, newTime)
+           atomically $ writeTVar slotVar newSlot'
+           go newSlot' newTime newDelay
 
-    checkValidClockChange :: (CurrentSlot, CurrentSlot) -> m ()
-    checkValidClockChange = \case
-        (CurrentSlotUnknown, CurrentSlot _) ->
-          -- Unknown-to-known typically happens when syncing catches up far
-          -- enough that we can now know what the current slot is.
-          return ()
-        (CurrentSlot _, CurrentSlotUnknown) ->
-          -- Known-to-unknown can happen when the ledger is no longer being
-          -- updated and time marches on past the end of the safe zone.
-          return ()
-        (CurrentSlotUnknown, CurrentSlotUnknown) ->
-          return ()
-        (CurrentSlot m, CurrentSlot n)
-          -- Normally we expect @n == m + 1@, but if the system is under heavy
-          -- load, we might miss a slot. We could have @n == m@ only if the
-          -- user's system clock was adjusted (say by an NTP process).
-          | m <  n    -> return ()
-          | m == n    -> return ()
-          | otherwise -> throwIO $ SystemClockMovedBack m n
+    checkValidClockChange ::
+         (CurrentSlot, RelativeTime)
+      -> (CurrentSlot, RelativeTime)
+      -> m CurrentSlot
+    checkValidClockChange (prevSlot, prevTime) (newSlot, newTime) =
+        case (prevSlot, newSlot) of
+          (CurrentSlotUnknown, CurrentSlot _)
+            -- Unknown-to-known typically happens when syncing catches up far
+            -- enough that we can now know what the current slot is.
+            -> return newSlot
+          (CurrentSlot _, CurrentSlotUnknown)
+            -- Known-to-unknown can happen when the ledger is no longer being
+            -- updated and time marches on past the end of the safe zone.
+            -> return newSlot
+          (CurrentSlotUnknown, CurrentSlotUnknown)
+            -> return newSlot
+          (CurrentSlot m, CurrentSlot n)
+            -- Normally we expect @n == m + 1@, but if the system is under heavy
+            -- load, we might miss a slot.
+            | m <  n
+            -> return newSlot
+            -- We could have @n == m@ or @n < m@ only if the user's system clock
+            -- was adjusted (say by an NTP process). We only allow a limited
+            -- rewinding of the clock, but never rewind the slot number
+            | m >= n
+            , prevTime `diffRelTime` newTime <= maxClockRewind
+            -> do traceWith tracer $ TraceSystemClockMovedBack prevTime newTime
+                  return prevSlot
+            | otherwise
+            -> throwIO $ SystemClockMovedBack m n
 
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}
 
--- | Get current slot, and delay until next slot
+-- | Get current slot, current time, and the delay until the next slot.
 getCurrentSlot' :: forall m xs. IOLike m
-                => Tracer m (RelativeTime, HF.PastHorizonException)
+                => Tracer m (TraceBlockchainTimeEvent RelativeTime)
                 -> SystemTime m
                 -> HF.RunWithCachedSummary xs m
                 -> m BackoffDelay
-                -> m (CurrentSlot, NominalDiffTime)
+                -> m (CurrentSlot, RelativeTime, NominalDiffTime)
 getCurrentSlot' tracer SystemTime{..} run getBackoffDelay = do
     now   <- systemTimeCurrent
     mSlot <- atomically $ HF.cachedRunQuery run $ HF.wallclockToSlot now
     case mSlot of
       Left ex -> do
         -- give up for now and backoff; see 'BackoffDelay'
-        traceWith tracer (now, ex)
+        traceWith tracer $ TraceCurrentSlotUnknown now ex
         BackoffDelay delay <- getBackoffDelay
-        return (CurrentSlotUnknown, delay)
+        return (CurrentSlotUnknown, now, delay)
       Right (slot, _inSlot, timeLeft) -> do
-        return (CurrentSlot slot, timeLeft)
+        return (CurrentSlot slot, now, timeLeft)