diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs index eefed42ad47..e6cb26b3fec 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs +++ b/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,6 +97,9 @@ prop_delayNextSlot TestDelayIO{..} = pick :: UTCTime -> SystemStart pick = SystemStart . Time.addUTCTime (negate tdioStart') + maxClockRewind :: NominalDiffTime + maxClockRewind = secondsToNominalDiffTime 0 + {------------------------------------------------------------------------------- Test delay using mock time -------------------------------------------------------------------------------} @@ -103,7 +107,8 @@ prop_delayNextSlot TestDelayIO{..} = -- | 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 -> diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs index 786620fe413..13a551e0f96 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs +++ b/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