Allow for limited wallclock rollback in simpleBlockchainTime

Also test it.

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,18 @@ prop_delayNextSlot TestDelayIO{..} =
         pick :: UTCTime -> SystemStart
         pick = SystemStart . Time.addUTCTime (negate tdioStart')
 
+    maxClockRewind :: NominalDiffTime
+    maxClockRewind = secondsToNominalDiffTime 0
+
 {-------------------------------------------------------------------------------
   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 +145,42 @@ 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 ss ->
+    runExcept $ (SlotNo 0 :) <$> go (need - 1) 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
+    advanceSchedule :: Schedule -> (Fixed E1, Schedule)
+    advanceSchedule (Schedule ss) =
+        case ss of
+          []    -> (0.0, Schedule [0.0])
+          [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 +195,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 +241,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 +267,26 @@ prop_delayNoClockShift =
     withMaxSuccess 1 $ ioProperty $ do
       now   <- getCurrentTime
       slots <- originalDelay $
-                 testOverrideDelay (SystemStart now) (slotLengthFromMillisec 100) 5
+                 testOverrideDelay
+                   (SystemStart now)
+                   (slotLengthFromMillisec 100)
+                   (secondsToNominalDiffTime 1)
+                   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/Simple.hs

@@ -31,8 +31,9 @@ simpleBlockchainTime :: forall m. IOLike m
                      => ResourceRegistry m
                      -> SystemTime m
                      -> SlotLength
+                     -> NominalDiffTime -- ^ Max clock rewind
                      -> m (BlockchainTime m)
-simpleBlockchainTime registry time slotLen = do
+simpleBlockchainTime registry time slotLen maxClockRewind = do
     systemTimeWait time
 
     -- Fork thread that continuously updates the current slot
@@ -55,7 +56,7 @@ simpleBlockchainTime registry time slotLen = do
       where
         go :: SlotNo -> m Void
         go current = do
-          next <- waitUntilNextSlot time slotLen current
+          next <- waitUntilNextSlot time slotLen maxClockRewind current
           atomically $ writeTVar slotVar next
           go next
 
@@ -87,19 +88,22 @@ getWallClockSlot SystemTime{..} slotLen =
 
 -- | Wait until the next slot
 --
--- Takes the current slot number to guard against system clock changes. Any
--- clock changes that would result in the slot number to /decrease/ will result
--- in a fatal 'SystemClockMovedBackException'. When this exception is thrown,
--- the node will shut down, and should be restarted with (full?) validation
--- enabled: it is conceivable that blocks got moved to the immutable DB that,
--- due to the clock change, should not be considered immutable anymore.
+-- Takes the current slot number to guard against system clock changes. If the
+-- clock changes back further than the max clock rewind parameter, a fatal
+-- 'SystemClockMovedBack' will be thrown. When this exception is thrown, the
+-- node will shut down, and should be restarted with (full?) validation enabled:
+-- it is conceivable that blocks got moved to the immutable DB that, due to the
+-- clock change, should not be considered immutable anymore.
+--
+-- If the clock changed back less than the max clock rewind parameter, we stay
+-- in the same slot for longer and don't throw an exception.
 waitUntilNextSlot :: IOLike m
                   => SystemTime m
-                  -> NominalDiffTime -- ^ Max clock rewind
                   -> SlotLength
-                  -> SlotNo    -- ^ Current slot number
+                  -> NominalDiffTime  -- ^ Max clock rewind
+                  -> SlotNo           -- ^ Current slot number
                   -> m SlotNo
-waitUntilNextSlot time@SystemTime{..} maxClockRewind slotLen oldCurrent = do
+waitUntilNextSlot time@SystemTime{..} slotLen maxClockRewind oldCurrent = do
     now <- systemTimeCurrent
 
     let delay = delayUntilNextSlot slotLen now
@@ -115,15 +119,21 @@ waitUntilNextSlot time@SystemTime{..} maxClockRewind slotLen oldCurrent = do
     --   client running on the system), it's possible that we are still in the
     --   /old/ current slot. If this happens, we just wait again; nothing bad
     --   has happened, we just stay in one slot for longer.
-    -- o If the system clock is adjusted back more than that, we might be in
-    --   a slot number /before/ the old current slot. In that case, we throw
-    --   an exception (see discussion above).
+    -- o If the system clock is adjusted back more than that, we might be in a
+    --   slot number /before/ the old current slot. In that case, if the
+    --   adjustment is <= the max rewind parameter, we allow it, but stay in the
+    --   same slot. Just like the previous case, we will stay in one slot for
+    --   longer.
+    -- o If the system clock is adjusted back more than the max rewind
+    --   parameter, we throw an exception (see discussion above).
 
-    (newCurrent, _timeInNewCurrent) <- getWallClockSlot time slotLen
+    afterDelay <- systemTimeCurrent
+    let (newCurrent, _timeInNewCurrent) = slotFromUTCTime slotLen afterDelay
 
     if | newCurrent > oldCurrent ->
            return newCurrent
-       | newCurrent == oldCurrent ->
-           waitUntilNextSlot time maxClockRewind slotLen oldCurrent
+       | newCurrent <= oldCurrent
+       , now `diffRelTime` afterDelay <= maxClockRewind ->
+           waitUntilNextSlot time slotLen maxClockRewind oldCurrent
        | otherwise ->
            throwIO $ SystemClockMovedBack oldCurrent newCurrent