Skip to content

Commit

Permalink
Merge #2785
Browse files Browse the repository at this point in the history 
2785: Allow for limited wallclock rollback r=mrBliss a=mrBliss

Fixes #2781.

By default, we will allow the system clock to roll back three seconds to account for time changes because of NTP. When this happens, `TraceSystemClockMovedBack` will be traced. Not that the current slot won't decrease, we'll just stay in the same slot longer.

When the system clock rolls back more than three seconds, we still shut down with the fatal `SystemClockMovedBack` exception.

Co-authored-by: Thomas Winant <thomas@well-typed.com>
  • Loading branch information
@iohk-bors @mrBliss
iohk-bors[bot] and mrBliss authored Dec 2, 2020
2 parents 7e00984 + fe4641d commit 1681055
Show file tree
Hide file tree
Showing 8 changed files with 189 additions and 107 deletions.
9 changes: 4 additions & 5 deletions ouroboros-consensus-test/src/Test/ThreadNet/Network.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))
Expand Down Expand Up @@ -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
Expand Down
101 changes: 67 additions & 34 deletions ouroboros-consensus-test/test-consensus/Test/Consensus/BlockchainTime/Simple.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand All @@ -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))
]
Expand Down Expand Up @@ -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
Expand All @@ -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 ->
Expand Down
6 changes: 3 additions & 3 deletions ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/Default.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..))

Expand All @@ -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
Expand All @@ -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
Expand Down
100 changes: 61 additions & 39 deletions ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs
View file
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -86,6 +95,7 @@ hardForkBlockchainTime args = do
, hfbtRegistry = registry
, hfbtSystemTime = time@SystemTime{..}
, hfbtTracer = tracer
, hfbtMaxClockRewind = maxClockRewind
} = args

summarize :: LedgerState blk -> HF.Summary (HardForkIndices blk)
Expand All @@ -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)
Loading

0 comments on commit 1681055

Please sign in to comment.