diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/EarlyExit.hs index abd36d33f6e..bf774ab1e76 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/EarlyExit.hs @@ -207,15 +207,6 @@ instance MonadTime m => MonadTime (WithEarlyExit m) where instance MonadDelay m => MonadDelay (WithEarlyExit m) where threadDelay = lift . threadDelay -instance (MonadTimer m, MonadFork m) => MonadTimer (WithEarlyExit m) where - newtype Timeout (WithEarlyExit m) = WrapTimeout { unwrapTimeout :: Timeout m } - - newTimeout d = lift $ WrapTimeout <$> newTimeout d - readTimeout t = lift $ readTimeout (unwrapTimeout t) - updateTimeout t = lift . updateTimeout (unwrapTimeout t) - cancelTimeout t = lift $ cancelTimeout (unwrapTimeout t) - timeout d = earlyExit . timeout d . withEarlyExit - {------------------------------------------------------------------------------- Finally, the consensus IOLike wrapper -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/IOLike.hs index e65f21739ae..0dadf3c4efa 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/IOLike.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Util/IOLike.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Util.IOLike ( , MonadFork(..) -- TODO: Should we hide this in favour of MonadAsync? , MonadThread(..) -- *** MonadAsync + , MonadAsyncSTM(..) , MonadAsync(..) , ExceptionInLinkedThread(..) , linkTo @@ -30,7 +31,6 @@ module Ouroboros.Consensus.Util.IOLike ( , addTime , diffTime -- *** MonadDelay - , MonadTimer(..) , MonadDelay(..) -- *** Cardano prelude , NoUnexpectedThunks(..) @@ -56,7 +56,7 @@ class ( MonadAsync m , MonadFork m , MonadST m , MonadTime m - , MonadTimer m + , MonadDelay m , MonadThread m , MonadThrow m , MonadCatch m diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/BlockchainTime/WallClock.hs b/ouroboros-consensus/test-consensus/Test/Consensus/BlockchainTime/WallClock.hs index c49ce745071..9f0387b53fc 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/BlockchainTime/WallClock.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/BlockchainTime/WallClock.hs @@ -12,21 +12,36 @@ module Test.Consensus.BlockchainTime.WallClock (tests) where +import Control.Exception (SomeException, fromException) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Tracer +import Data.Fixed +import Data.Time.Calendar as Time import qualified Data.Time.Clock as Time import Test.QuickCheck hiding (Fixed) import Test.Tasty hiding (after) import Test.Tasty.HUnit import Test.Tasty.QuickCheck hiding (Fixed) +import Cardano.Prelude (AllowThunk (..), NoUnexpectedThunks) +import Cardano.Slotting.Slot (SlotNo (..)) + +import Control.Monad.IOSim + import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.ResourceRegistry import Test.Util.Orphans.Arbitrary () import Test.Util.Orphans.IOLike () +import Test.Util.Range tests :: TestTree tests = testGroup "WallClock" [ testProperty "delayNextSlot" prop_delayNextSlot + , testProperty "delayClockShift" prop_delayClockShift + , testProperty "delayNoClockShift" prop_delayNoClockShift ] {------------------------------------------------------------------------------- @@ -84,3 +99,259 @@ prop_delayNextSlot TestDelayIO{..} = where pick :: UTCTime -> SystemStart pick = SystemStart . Time.addUTCTime (negate tdioStart') + +{------------------------------------------------------------------------------- + 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). +newtype Schedule = Schedule { getSchedule :: [Fixed E1] } + deriving stock (Show) + deriving NoUnexpectedThunks via AllowThunk Schedule + +-- | Translate an offset in the schedule to a slot +-- +-- Assumes slot length is 1. +offsetToSlot :: Fixed E1 -> SlotNo +offsetToSlot = SlotNo . floor + +-- | Does a schedule ever go back? +-- +-- Used for labelling. +scheduleGoesBack :: Schedule -> Bool +scheduleGoesBack (Schedule []) = False +scheduleGoesBack (Schedule (t:ts)) = go t ts + where + go :: Ord a => a -> [a] -> Bool + go _ [] = False + go x (y:ys) = y < x || go y ys + +-- | How often do two subsequent time entries fall into the same slot? +-- +-- Used for labelling. +scheduleCountSkips :: Schedule -> Int +scheduleCountSkips (Schedule []) = 0 +scheduleCountSkips (Schedule (t:ts)) = go t ts + where + go :: Fixed E1 -> [Fixed E1] -> Int + go _ [] = 0 + go x (y:ys) = (if offsetToSlot x == offsetToSlot y then 1 else 0) + go y ys + +-- | Predict the outcome of a given schedule +-- +-- 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@. +-- +-- NOTE: Assumes the slot length is 1 for these sets. +model :: Int -> Schedule -> Either (SlotNo, SlotNo) [SlotNo] +model = \need (Schedule s) -> runExcept $ go need s (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 + fromIntegral n) | n <- [1 .. need]] + + 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') + where + now' :: SlotNo + now' = offsetToSlot s + +instance Arbitrary Schedule where + arbitrary = + -- We only collect 100 samples. Generate a few more, potentially, but also + -- often generate fewer (which would give us the default behaviour). + Schedule <$> (go 0 =<< choose (0, 110)) + where + go :: Fixed E1 -> Int -> Gen [Fixed E1] + go _ 0 = return [] + go now n = do + now' <- frequency [ + -- If time goes back too often, most runs end in an exception + (100, (\delta -> now + fixedFromDeci delta) <$> choose (0, 30)) + + -- Occassionally just pick an entirely random time + , (1, fixedFromDeci <$> choose (0, 100)) + ] + (now':) <$> go now' (n - 1) + + fixedFromDeci :: Integer -> Fixed E1 + fixedFromDeci = MkFixed + + shrink (Schedule s) = Schedule <$> shrinkList shrinkOffset s + where + shrinkOffset :: Fixed E1 -> [Fixed E1] + shrinkOffset (MkFixed o) = MkFixed <$> shrink o + +prop_delayClockShift :: Schedule -> Property +prop_delayClockShift schedule = + tabulate "schedule length" [show $ range (length (getSchedule schedule))] $ + tabulate "schedule goes back" [show $ scheduleGoesBack schedule] $ + tabulate "schedule skips" [show $ range (scheduleCountSkips schedule)] $ + case model numSlots schedule of + Left (before, after) -> + case testResult of + Left (FailureException e) -> + checkException before after e + Left e -> + counterexample ("Unexpected simulator failure " ++ show e) $ + property False + Right slots' -> + counterexample ("Expected exception but got " ++ show slots') $ + property False + + Right slots -> + case testResult of + Left e -> + counterexample ("Expected normal termination, but got " ++ show e) $ + property False + Right slots' -> + slots' === slots + where + numSlots :: Int + numSlots = 100 + + testResult :: Either Failure [SlotNo] + testResult = overrideDelay dawnOfTime schedule $ + testOverrideDelay (SystemStart dawnOfTime) (SlotLength 1) numSlots + + checkException :: SlotNo -> SlotNo -> SomeException -> Property + checkException before after e + | Just (ExceptionInLinkedThread _ e') <- fromException e = + checkException before after e' + | Just (SystemClockMovedBack _ before' after') <- fromException e = + counterexample ("Got expected exception " ++ show e) $ + conjoin [ + before' === before + , after' === after + ] + | otherwise = + counterexample ("Unexpected exception: " ++ show e) $ + property False + +-- | Just as a sanity check, verify that this works in IO +prop_delayNoClockShift :: Property +prop_delayNoClockShift = + withMaxSuccess 1 $ ioProperty $ do + now <- getCurrentTime + slots <- originalDelay $ + testOverrideDelay (SystemStart now) (SlotLength 0.1) 5 + assertEqual "slots" slots [SlotNo n | n <- [1..5]] + +testOverrideDelay :: forall m. (IOLike m, MonadDelay (OverrideDelay m)) + => SystemStart + -> SlotLength + -> Int -- ^ Number of slots to collect + -> OverrideDelay m [SlotNo] +testOverrideDelay systemStart slotLength numSlots = do + result <- withRegistry $ \registry -> do + time <- realBlockchainTime + registry + nullTracer + systemStart + (focusSlotLengths $ singletonSlotLengths slotLength) + slotsVar <- newTVarM [] + cancelCollection <- onSlotChange time $ \slotNo -> + atomically $ modifyTVar slotsVar (slotNo :) + -- Wait to collect the required number of slots + slots <- atomically $ do + slots <- readTVar slotsVar + when (length slots < numSlots) $ retry + return slots + cancelCollection + return $ reverse slots + return result + +dawnOfTime :: UTCTime +dawnOfTime = Time.UTCTime (Time.ModifiedJulianDay 0) 0 + +{------------------------------------------------------------------------------- + Test-programmable time +-------------------------------------------------------------------------------} + +-- | IO wrapper where we can program the effect of 'threadDelay' +newtype OverrideDelay m a = OverrideDelay { + unOverrideDelay :: ReaderT (StrictTVar m Schedule) m a + } + deriving ( Functor + , Applicative + , Monad + , MonadThrow + , MonadCatch + , MonadMask + , MonadSTM + , MonadTime + , MonadThread + , MonadFork + , MonadAsync + , MonadST + ) + +deriving via AllowThunk (OverrideDelay s a) + instance NoUnexpectedThunks (OverrideDelay s a) + +deriving via AllowThunk (StrictTVar (OverrideDelay s) a) + instance NoUnexpectedThunks (StrictTVar (OverrideDelay s) a) + +deriving via AllowThunk (StrictMVar (OverrideDelay s) a) + instance NoUnexpectedThunks (StrictMVar (OverrideDelay s) a) + +instance MonadDelay (OverrideDelay (SimM s)) where + threadDelay d = OverrideDelay $ ReaderT $ \schedule -> do + -- Do the original delay. This is important, because otherwise this + -- turns into a busy loop in the simulator + threadDelay d + -- However, the time /after/ the delay will be determined by the + -- schedule (unless it is empty, in which case the threadDelay behaves + -- as normal). + mOverride <- atomically $ updateTVar schedule nextDelay + case mOverride of + Nothing -> return () + Just t -> setCurrentTime t + where + nextDelay :: Schedule -> (Schedule, Maybe UTCTime) + nextDelay = \case + Schedule [] -> (Schedule [], Nothing) + Schedule (t:ts) -> (Schedule ts, Just $ offsetToTime t) + + offsetToTime :: Fixed E1 -> UTCTime + offsetToTime t = Time.addUTCTime (realToFrac t) dawnOfTime + +-- | The IO instance just uses the default delay +instance MonadDelay (OverrideDelay IO) where + threadDelay d = OverrideDelay $ ReaderT $ \_schedule -> threadDelay d + +instance (IOLike m, MonadDelay (OverrideDelay m)) => IOLike (OverrideDelay m) + +overrideDelay :: UTCTime + -> Schedule + -> (forall s. OverrideDelay (SimM s) a) + -> Either Failure a +overrideDelay start schedule ma = runSim $ do + setCurrentTime start + scheduleVar <- newTVarM schedule + runReaderT (unOverrideDelay ma) scheduleVar + +originalDelay :: OverrideDelay IO a -> IO a +originalDelay ma = runReaderT (unOverrideDelay ma) (error "schedule unused") diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/ResourceRegistry.hs b/ouroboros-consensus/test-consensus/Test/Consensus/ResourceRegistry.hs index c57cd021633..3b554f28609 100644 --- a/ouroboros-consensus/test-consensus/Test/Consensus/ResourceRegistry.hs +++ b/ouroboros-consensus/test-consensus/Test/Consensus/ResourceRegistry.hs @@ -30,6 +30,8 @@ import Data.Typeable import qualified Generics.SOP as SOP import GHC.Generics (Generic, Generic1) +import Control.Monad.Class.MonadTimer + import Test.QuickCheck (Gen) import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Monadic as QC