From db594c17a870377d44131ec231b20126f6a3d186 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 30 Nov 2020 11:48:42 +0100 Subject: [PATCH 1/3] Allow for limited wallclock rollback in hardForkBlockchainTime Fixes #2781. --- .../src/Test/ThreadNet/Network.hs | 16 ++- .../BlockchainTime/WallClock/HardFork.hs | 113 ++++++++++++------ .../BlockchainTime/WallClock/Simple.hs | 5 +- .../BlockchainTime/WallClock/Util.hs | 13 ++ .../src/Ouroboros/Consensus/Node.hs | 16 ++- 5 files changed, 114 insertions(+), 49 deletions(-) diff --git a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs index 5e72d15a8ef..7a11f7f381e 100644 --- a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs +++ b/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,19 @@ runThreadNetwork systemTime ThreadNetworkArgs , hfbtSystemTime = OracularClock.finiteSystemTime clock , hfbtTracer = contramap - (\(t, e) -> + -- We don't really have a SystemStart in the tests + (let systemStart = SystemStart dawnOfTime + in \case + UnknownCurrentSlot t ex -> TraceCurrentSlotUnknown - -- We don't really have a SystemStart in the tests - (fromRelativeTime (SystemStart dawnOfTime) t) - e) + (fromRelativeTime systemStart t) + ex + SystemClockMovedBackABit oldT newT -> + TraceSystemClockMovedBack + (fromRelativeTime systemStart oldT) + (fromRelativeTime systemStart newT)) (blockchainTimeTracer tracers) + , hfbtMaxClockRewind = secondsToNominalDiffTime 0 } let kaRng = case seed of diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs index 66c8e39e250..c6574abb1e3 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork ( - BackoffDelay (..), - HardForkBlockchainTimeArgs (..), - hardForkBlockchainTime, + BackoffDelay (..) + , HardForkBlockchainTimeArgs (..) + , hardForkBlockchainTime + , HardForkBlockchainTimeEvent (..) ) where import Control.Monad @@ -47,6 +47,18 @@ import Ouroboros.Consensus.Util.Time -- incur computational overhead.) newtype BackoffDelay = BackoffDelay NominalDiffTime +-- | Events traced by 'hardForkBlockchainTime' +data HardForkBlockchainTimeEvent = + -- | The current slot is unknown + UnknownCurrentSlot RelativeTime HF.PastHorizonException + + -- | The system clock moved back a bit, but less than 'hfbtMaxClockRewind', + -- e.g., because of an NTP sync. This is acceptable. + -- + -- We include the old and the new time. + | SystemClockMovedBackABit RelativeTime RelativeTime + deriving (Show) + data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs { hfbtBackoffDelay :: m BackoffDelay -- ^ See 'BackoffDelay' @@ -54,8 +66,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 HardForkBlockchainTimeEvent + , 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 + -- 'SystemClockMovedBackABit' 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 +92,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 +108,7 @@ hardForkBlockchainTime args = do , hfbtRegistry = registry , hfbtSystemTime = time@SystemTime{..} , hfbtTracer = tracer + , hfbtMaxClockRewind = maxClockRewind } = args summarize :: LedgerState blk -> HF.Summary (HardForkIndices blk) @@ -94,57 +117,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 $ SystemClockMovedBackABit 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 HardForkBlockchainTimeEvent -> 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 $ UnknownCurrentSlot 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) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs index 66fb2363a35..786620fe413 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs @@ -95,10 +95,11 @@ getWallClockSlot SystemTime{..} slotLen = -- due to the clock change, should not be considered immutable anymore. waitUntilNextSlot :: IOLike m => SystemTime m + -> NominalDiffTime -- ^ Max clock rewind -> SlotLength -> SlotNo -- ^ Current slot number -> m SlotNo -waitUntilNextSlot time@SystemTime{..} slotLen oldCurrent = do +waitUntilNextSlot time@SystemTime{..} maxClockRewind slotLen oldCurrent = do now <- systemTimeCurrent let delay = delayUntilNextSlot slotLen now @@ -123,6 +124,6 @@ waitUntilNextSlot time@SystemTime{..} slotLen oldCurrent = do if | newCurrent > oldCurrent -> return newCurrent | newCurrent == oldCurrent -> - waitUntilNextSlot time slotLen oldCurrent + waitUntilNextSlot time maxClockRewind slotLen oldCurrent | otherwise -> throwIO $ SystemClockMovedBack oldCurrent newCurrent diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs index 721b5a2b738..2d6230bef73 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs @@ -41,6 +41,19 @@ data TraceBlockchainTimeEvent = -- current time and the upper bound should rapidly decrease with consecutive -- 'TraceCurrentSlotUnknown' messages during syncing. | TraceCurrentSlotUnknown UTCTime PastHorizonException + + -- | The system clock moved back an acceptable time span, e.g., because of + -- an NTP sync. + -- + -- The system clock moved back such that the new current slot would be + -- smaller than the previous one. If this is within the configured limit, we + -- trace this warning but *do not change the current slot*. The current slot + -- never decreases, but the current slot may stay the same longer than + -- expected. + -- + -- When the system clock moved back more than the configured limit, we shut + -- down with a fatal exception. + | TraceSystemClockMovedBack UTCTime UTCTime deriving (Show) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index 2845a8b5028..da8f26ec2d5 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE Rank2Types #-} @@ -99,6 +100,7 @@ import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.ResourceRegistry +import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Consensus.Storage.ChainDB (ChainDB, ChainDbArgs) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB @@ -272,11 +274,17 @@ runWith RunNodeArgs{..} LowLevelRunNodeArgs{..} = , hfbtSystemTime = systemTime , hfbtTracer = contramap - (\(t, ex) -> - TraceCurrentSlotUnknown - (fromRelativeTime systemStart t) - ex) + (\case + UnknownCurrentSlot t ex -> + TraceCurrentSlotUnknown + (fromRelativeTime systemStart t) + ex + SystemClockMovedBackABit oldT newT -> + TraceSystemClockMovedBack + (fromRelativeTime systemStart oldT) + (fromRelativeTime systemStart newT)) (blockchainTimeTracer rnTraceConsensus) + , hfbtMaxClockRewind = secondsToNominalDiffTime 20 } nodeKernelArgs <- From 55696f7c9bbff4dbe0249a1ab64e2e4bc4d6fbb8 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Tue, 1 Dec 2020 17:47:25 +0100 Subject: [PATCH 2/3] Allow for limited wallclock rollback in simpleBlockchainTime Also test it. --- .../Test/Consensus/BlockchainTime/Simple.hs | 101 ++++++++++++------ .../BlockchainTime/WallClock/Simple.hs | 44 +++++--- 2 files changed, 94 insertions(+), 51 deletions(-) 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..8e92440519b 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,11 @@ 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 -------------------------------------------------------------------------------} @@ -103,7 +109,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 +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 -> diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs index 786620fe413..fd100877b04 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' exception 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 From 8f01308dc39905e64e6477607415b1f1991b651b Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Wed, 2 Dec 2020 15:49:55 +0100 Subject: [PATCH 3/3] Unify TraceBlockchainTimeEvent with HardForkBlockchainTimeEvent Both were isomorphic up to the time used (`UTCTime` vs `RelativeTime`). Generalise `TraceBlockchainTimeEvent` over the time and use that in both places. --- .../src/Test/ThreadNet/Network.hs | 13 ++--------- .../BlockchainTime/WallClock/Default.hs | 6 ++--- .../BlockchainTime/WallClock/HardFork.hs | 23 ++++--------------- .../BlockchainTime/WallClock/Util.hs | 14 +++++++---- .../src/Ouroboros/Consensus/Node.hs | 11 +-------- .../src/Ouroboros/Consensus/Node/Tracers.hs | 3 ++- 6 files changed, 22 insertions(+), 48 deletions(-) diff --git a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs index 7a11f7f381e..e2fb3cca329 100644 --- a/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-test/src/Test/ThreadNet/Network.hs @@ -958,17 +958,8 @@ runThreadNetwork systemTime ThreadNetworkArgs , hfbtSystemTime = OracularClock.finiteSystemTime clock , hfbtTracer = contramap - -- We don't really have a SystemStart in the tests - (let systemStart = SystemStart dawnOfTime - in \case - UnknownCurrentSlot t ex -> - TraceCurrentSlotUnknown - (fromRelativeTime systemStart t) - ex - SystemClockMovedBackABit oldT newT -> - TraceSystemClockMovedBack - (fromRelativeTime systemStart oldT) - (fromRelativeTime systemStart newT)) + -- We don't really have a SystemStart in the tests + (fmap (fromRelativeTime (SystemStart dawnOfTime))) (blockchainTimeTracer tracers) , hfbtMaxClockRewind = secondsToNominalDiffTime 0 } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Default.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Default.hs index e9d2757b5bd..f161a487f95 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Default.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs index c6574abb1e3..99d7864c4d2 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs @@ -7,7 +7,6 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork ( BackoffDelay (..) , HardForkBlockchainTimeArgs (..) , hardForkBlockchainTime - , HardForkBlockchainTimeEvent (..) ) where import Control.Monad @@ -47,18 +46,6 @@ import Ouroboros.Consensus.Util.Time -- incur computational overhead.) newtype BackoffDelay = BackoffDelay NominalDiffTime --- | Events traced by 'hardForkBlockchainTime' -data HardForkBlockchainTimeEvent = - -- | The current slot is unknown - UnknownCurrentSlot RelativeTime HF.PastHorizonException - - -- | The system clock moved back a bit, but less than 'hfbtMaxClockRewind', - -- e.g., because of an NTP sync. This is acceptable. - -- - -- We include the old and the new time. - | SystemClockMovedBackABit RelativeTime RelativeTime - deriving (Show) - data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs { hfbtBackoffDelay :: m BackoffDelay -- ^ See 'BackoffDelay' @@ -66,7 +53,7 @@ data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs , hfbtLedgerConfig :: LedgerConfig blk , hfbtRegistry :: ResourceRegistry m , hfbtSystemTime :: SystemTime m - , hfbtTracer :: Tracer m HardForkBlockchainTimeEvent + , hfbtTracer :: Tracer m (TraceBlockchainTimeEvent RelativeTime) , hfbtMaxClockRewind :: NominalDiffTime -- ^ Maximum time the clock can be rewound without throwing a fatal -- 'SystemClockMovedBack' exception. @@ -76,7 +63,7 @@ data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs -- slot increase. -- -- We allow the system clock to rewind up to 'hfbtMaxClockRewind', tracing a - -- 'SystemClockMovedBackABit' message in such cases. Note that the current + -- 'TraceSystemClockMovedBack' message in such cases. Note that the current -- slot *never decreases*, we just wait a bit longer in the same slot. } @@ -156,7 +143,7 @@ hardForkBlockchainTime args = do -- rewinding of the clock, but never rewind the slot number | m >= n , prevTime `diffRelTime` newTime <= maxClockRewind - -> do traceWith tracer $ SystemClockMovedBackABit prevTime newTime + -> do traceWith tracer $ TraceSystemClockMovedBack prevTime newTime return prevSlot | otherwise -> throwIO $ SystemClockMovedBack m n @@ -167,7 +154,7 @@ hardForkBlockchainTime args = do -- | Get current slot, current time, and the delay until the next slot. getCurrentSlot' :: forall m xs. IOLike m - => Tracer m HardForkBlockchainTimeEvent + => Tracer m (TraceBlockchainTimeEvent RelativeTime) -> SystemTime m -> HF.RunWithCachedSummary xs m -> m BackoffDelay @@ -178,7 +165,7 @@ getCurrentSlot' tracer SystemTime{..} run getBackoffDelay = do case mSlot of Left ex -> do -- give up for now and backoff; see 'BackoffDelay' - traceWith tracer $ UnknownCurrentSlot now ex + traceWith tracer $ TraceCurrentSlotUnknown now ex BackoffDelay delay <- getBackoffDelay return (CurrentSlotUnknown, now, delay) Right (slot, _inSlot, timeLeft) -> do diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs index 2d6230bef73..54e9719d724 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} -- | Support for defining 'BlockchainTime' instances @@ -9,7 +10,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Util ( ) where import Control.Exception (Exception) -import Data.Time (NominalDiffTime, UTCTime) +import Data.Time (NominalDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime.WallClock.Types @@ -21,7 +22,10 @@ import Ouroboros.Consensus.HardFork.History (PastHorizonException) -------------------------------------------------------------------------------} -- | Time related tracing -data TraceBlockchainTimeEvent = +-- +-- The @t@ parameter can be instantiated by the time, e.g., @UTCTime@ or +-- @RelativeTime@. +data TraceBlockchainTimeEvent t = -- | The start time of the blockchain time is in the future -- -- We have to block (for 'NominalDiffTime') until that time comes. @@ -40,7 +44,7 @@ data TraceBlockchainTimeEvent = -- bounds between which we /can/ do conversions. The distance between the -- current time and the upper bound should rapidly decrease with consecutive -- 'TraceCurrentSlotUnknown' messages during syncing. - | TraceCurrentSlotUnknown UTCTime PastHorizonException + | TraceCurrentSlotUnknown t PastHorizonException -- | The system clock moved back an acceptable time span, e.g., because of -- an NTP sync. @@ -53,8 +57,8 @@ data TraceBlockchainTimeEvent = -- -- When the system clock moved back more than the configured limit, we shut -- down with a fatal exception. - | TraceSystemClockMovedBack UTCTime UTCTime - deriving (Show) + | TraceSystemClockMovedBack t t + deriving (Show, Functor) {------------------------------------------------------------------------------- Exceptions diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs index da8f26ec2d5..be6adf6b07c 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node.hs @@ -273,16 +273,7 @@ runWith RunNodeArgs{..} LowLevelRunNodeArgs{..} = , hfbtRegistry = registry , hfbtSystemTime = systemTime , hfbtTracer = - contramap - (\case - UnknownCurrentSlot t ex -> - TraceCurrentSlotUnknown - (fromRelativeTime systemStart t) - ex - SystemClockMovedBackABit oldT newT -> - TraceSystemClockMovedBack - (fromRelativeTime systemStart oldT) - (fromRelativeTime systemStart newT)) + contramap (fmap (fromRelativeTime systemStart)) (blockchainTimeTracer rnTraceConsensus) , hfbtMaxClockRewind = secondsToNominalDiffTime 20 } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs index 53bf8c33a4a..501088130a0 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Node/Tracers.hs @@ -18,6 +18,7 @@ module Ouroboros.Consensus.Node.Tracers import Control.Tracer (Tracer, nullTracer, showTracing) import Data.Text (Text) +import Data.Time (UTCTime) import Ouroboros.Network.BlockFetch (FetchDecision, TraceFetchClientState, TraceLabelPeer) @@ -59,7 +60,7 @@ data Tracers' remotePeer localPeer blk f = Tracers , localTxSubmissionServerTracer :: f (TraceLocalTxSubmissionServerEvent blk) , mempoolTracer :: f (TraceEventMempool blk) , forgeTracer :: f (TraceLabelCreds (TraceForgeEvent blk)) - , blockchainTimeTracer :: f TraceBlockchainTimeEvent + , blockchainTimeTracer :: f (TraceBlockchainTimeEvent UTCTime) , forgeStateInfoTracer :: f (TraceLabelCreds (ForgeStateInfo blk)) , keepAliveClientTracer :: f (TraceKeepAliveClient remotePeer) }