{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Intended for qualified import
--
-- > import Test.Util.OracularClock (OracularClock(..))
-- > import qualified Test.Util.OracularClock as OracularClock
module Test.Util.HardFork.OracularClock
  ( EndOfDaysException (..)
  , OracularClock (..)
  , forkEachSlot
  , mkOracularClock
  ) where

import Control.Monad (void, when)
import Control.ResourceRegistry
import Data.Foldable (toList)
import Data.Function (fix)
import Data.Time
import GHC.Stack
import Ouroboros.Consensus.Block
import qualified Ouroboros.Consensus.BlockchainTime as BTime
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.Time (nominalDelay)
import Test.Util.HardFork.Future
  ( Future
  , futureSlotLengths
  , futureSlotToTime
  , futureTimeToSlot
  )
import Test.Util.Slots (NumSlots (..))

-- | A clock that knows the future
--
-- This clock's closure contains a 'BTime.SystemTime', a 'Future', and a
-- 'NumSlots'. Once all 'NumSlots' have passed, the clock is /exhausted/ and
-- all of its methods begin throwing 'EndOfDaysException'.
--
-- Notably, 'waitUntilDone' blocks until the the clock is exhausted; so the
-- continuation of that call should promptly reap other threads using this
-- clock because they will otherwise soon raise 'EndOfDaysException'.
--
-- Note: Though the wallclock-slot correspondence depends on the ledger state,
-- we have designed our ledgers so that all nodes necessarily use the same
-- correspondence in the absence of a Common Prefix violation. This ensures all
-- nodes adopt the same timeline, which must be /the/ 'Future' that this clock
-- anticipates.
data OracularClock m = OracularClock
  { forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
blockUntilSlot :: SlotNo -> m Bool
  -- ^ Returns 'True' if the requested slot is already over
  , forall (m :: * -> *). OracularClock m -> m NominalDiffTime
delayUntilNextSlot :: m NominalDiffTime
  -- ^ The current delay duration until the onset of the next slot
  , forall (m :: * -> *). OracularClock m -> SystemTime m
finiteSystemTime :: BTime.SystemTime m
  -- ^ A mock system time
  --
  -- Note that 'BTime.systemTimeCurrent' eventually raises
  -- 'EndOfDaysException'.
  , forall (m :: * -> *). OracularClock m -> m SlotNo
getCurrentSlot :: m SlotNo
  -- ^ The current slot
  , forall (m :: * -> *).
OracularClock m
-> HasCallStack =>
   ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ ::
      HasCallStack =>
      ResourceRegistry m ->
      String ->
      (SlotNo -> m ()) ->
      m (m ())
  -- ^ See 'forkEachSlot'
  , forall (m :: * -> *). OracularClock m -> m ()
waitUntilDone :: m ()
  -- ^ Block until the clock is exhausted
  }

-- | Forks a thread that executes an action at the onset of each slot
--
-- Returns an action that cancels the thread.
--
-- INVARIANT: In @io-sim@, there is no race:
-- @'finiteSystemTime'.systemTimeCurrent@ and hence 'getCurrentSlot' called
-- from within the given action will always return the correct slot.
--
-- See the discussion of ticker threads in 'getCurrentSlot'.
forkEachSlot ::
  HasCallStack =>
  ResourceRegistry m ->
  OracularClock m ->
  String ->
  (SlotNo -> m ()) ->
  m (m ())
forkEachSlot :: forall (m :: * -> *).
HasCallStack =>
ResourceRegistry m
-> OracularClock m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot ResourceRegistry m
reg OracularClock m
clk = OracularClock m
-> HasCallStack =>
   ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forall (m :: * -> *).
OracularClock m
-> HasCallStack =>
   ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ OracularClock m
clk ResourceRegistry m
reg

-- jumping the hoop so HasCallStack is useful

-- | See 'OracularClock'
--
-- NOTE: Every method relies only on the given 'BTime.SystemTime'. For example,
-- there is no internal ticker thread underlying this 'OracularClock'. This
-- design avoids the risk of certain kinds of races, particularly with respect
-- to
-- 'Ouroboros.Consensus.BlockchainTime.WallClock.HardFork.hardForkBlockchainTime'
-- which also only relies on 'BTime.SystemTime'.
--
-- PREREQUISITE: The only assumption about the given 'BTime.SystemTime' is that
-- its 'BTime.systemCurrentTime' ticks before any 'threadDelay'-ed thread
-- scheduled to wake-up then does so. The 'BTime.defaultSystemTime' in the mock
-- 'IO' monad provided by @io-sim@ satisfies this assumption.
mkOracularClock ::
  forall m.
  IOLike m =>
  BTime.SystemTime m ->
  NumSlots ->
  Future ->
  OracularClock m
mkOracularClock :: forall (m :: * -> *).
IOLike m =>
SystemTime m -> NumSlots -> Future -> OracularClock m
mkOracularClock BTime.SystemTime{m ()
m RelativeTime
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
..} NumSlots
numSlots Future
future =
  OracularClock
    { blockUntilSlot :: SlotNo -> m Bool
blockUntilSlot = \SlotNo
slot -> do
        BTime.RelativeTime now <- m RelativeTime
finiteSystemTimeCurrent
        let later = Future -> SlotNo -> NominalDiffTime
futureSlotToTime Future
future SlotNo
slot

        -- refuse to block until @>= endOfDays@
        when (later >= endOfDays) $ do
          threadDelay $ nominalDelay $ endOfDays - now
          exhaustedM

        blockUntilTime now later
    , delayUntilNextSlot :: m NominalDiffTime
delayUntilNextSlot = do
        (_slot, leftInSlot, _slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent
        pure leftInSlot
    , finiteSystemTime :: SystemTime m
finiteSystemTime =
        BTime.SystemTime
          { systemTimeCurrent :: m RelativeTime
BTime.systemTimeCurrent = m RelativeTime
finiteSystemTimeCurrent
          , systemTimeWait :: m ()
BTime.systemTimeWait = m ()
systemTimeWait
          }
    , getCurrentSlot :: m SlotNo
getCurrentSlot = do
        (slot, _leftInSlot, _slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent
        pure slot
    , forkEachSlot_ :: HasCallStack =>
ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ = \ResourceRegistry m
rr String
threadLabel SlotNo -> m ()
action ->
        (Thread m (ZonkAny 0) -> m ())
-> m (Thread m (ZonkAny 0)) -> m (m ())
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Thread m (ZonkAny 0) -> m ()
forall (m :: * -> *) a. MonadAsync m => Thread m a -> m ()
cancelThread (m (Thread m (ZonkAny 0)) -> m (m ()))
-> m (Thread m (ZonkAny 0)) -> m (m ())
forall a b. (a -> b) -> a -> b
$
          ResourceRegistry m
-> String -> m (ZonkAny 0) -> m (Thread m (ZonkAny 0))
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
rr String
threadLabel (m (ZonkAny 0) -> m (Thread m (ZonkAny 0)))
-> m (ZonkAny 0) -> m (Thread m (ZonkAny 0))
forall a b. (a -> b) -> a -> b
$
            (m (ZonkAny 0) -> m (ZonkAny 0)) -> m (ZonkAny 0)
forall a. (a -> a) -> a
fix ((m (ZonkAny 0) -> m (ZonkAny 0)) -> m (ZonkAny 0))
-> (m (ZonkAny 0) -> m (ZonkAny 0)) -> m (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ \m (ZonkAny 0)
loop -> do
              -- INVARIANT the slot returned here ascends monotonically unless
              -- the underlying 'BTime.SystemTime' jumps backwards
              (slot, leftInSlot, _slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent

              let lbl = String
threadLabel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"
              -- fork the action, so it can't threadDelay us
              void $ forkLinkedThread rr lbl $ action slot

              threadDelay $ nominalDelay leftInSlot
              loop
    , waitUntilDone :: m ()
waitUntilDone = do
        BTime.RelativeTime now <- m RelativeTime
finiteSystemTimeCurrent
        void $ blockUntilTime now endOfDays
    }
 where
  -- when the clock becomes exhausted
  endOfDays :: NominalDiffTime
  endOfDays :: NominalDiffTime
endOfDays =
    ([NominalDiffTime] -> NominalDiffTime
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([NominalDiffTime] -> NominalDiffTime)
-> ([SlotLength] -> [NominalDiffTime])
-> [SlotLength]
-> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SlotLength -> NominalDiffTime)
-> [SlotLength] -> [NominalDiffTime]
forall a b. (a -> b) -> [a] -> [b]
map SlotLength -> NominalDiffTime
BTime.getSlotLength) ([SlotLength] -> NominalDiffTime)
-> [SlotLength] -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$
      (Int -> [SlotLength] -> [SlotLength]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) ([SlotLength] -> [SlotLength])
-> (Stream SlotLength -> [SlotLength])
-> Stream SlotLength
-> [SlotLength]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream SlotLength -> [SlotLength]
forall a. Stream a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) (Stream SlotLength -> [SlotLength])
-> Stream SlotLength -> [SlotLength]
forall a b. (a -> b) -> a -> b
$
        Future -> Stream SlotLength
futureSlotLengths Future
future
   where
    NumSlots Word64
n = NumSlots
numSlots

  -- what any method called at exactly @endOfDays@ or blocked as of
  -- @endOfDays@ ends up doing at the exact @endOfDays@ moment
  exhaustedM :: forall a. m a
  exhaustedM :: forall a. m a
exhaustedM = do
    -- throw if this thread isn't terminated in time
    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ Integer -> DiffTime
picosecondsToDiffTime Integer
1 -- the smallest possible delay
    EndOfDaysException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO EndOfDaysException
EndOfDaysException

  -- a 'BTime.systemTimeCurrent' that respects @endOfDays@
  finiteSystemTimeCurrent :: m BTime.RelativeTime
  finiteSystemTimeCurrent :: m RelativeTime
finiteSystemTimeCurrent = do
    t <- m RelativeTime
systemTimeCurrent

    -- check if clock is exhausted
    let tFinal = NominalDiffTime -> RelativeTime
BTime.RelativeTime NominalDiffTime
endOfDays
    when (t > tFinal) $ throwIO EndOfDaysException
    when (t == tFinal) $ exhaustedM

    pure t

  getPresent :: m (SlotNo, NominalDiffTime, BTime.SlotLength)
  getPresent :: m (SlotNo, NominalDiffTime, SlotLength)
getPresent = do
    BTime.RelativeTime now <- m RelativeTime
finiteSystemTimeCurrent
    pure $ futureTimeToSlot future now

  blockUntilTime :: NominalDiffTime -> NominalDiffTime -> m Bool
  blockUntilTime :: NominalDiffTime -> NominalDiffTime -> m Bool
blockUntilTime NominalDiffTime
now NominalDiffTime
later =
    case NominalDiffTime -> NominalDiffTime -> Ordering
forall a. Ord a => a -> a -> Ordering
compare NominalDiffTime
now NominalDiffTime
later of
      Ordering
LT -> do
        DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
nominalDelay (NominalDiffTime -> DiffTime) -> NominalDiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
later NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
now
        Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Ordering
EQ -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      Ordering
GT -> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- ie " too late "

-----

-- | A thread used an 'OracularClock' well after it was exhausted
--
-- A thread using an exhausted 'OracularClock' first briefly delays, so that
-- finalizers etc have a chance to terminate it. If that tear down isn't prompt
-- enough, the thread then throws this exception, which we don't catch
-- anywhere.
data EndOfDaysException = EndOfDaysException
  deriving Int -> EndOfDaysException -> String -> String
[EndOfDaysException] -> String -> String
EndOfDaysException -> String
(Int -> EndOfDaysException -> String -> String)
-> (EndOfDaysException -> String)
-> ([EndOfDaysException] -> String -> String)
-> Show EndOfDaysException
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> EndOfDaysException -> String -> String
showsPrec :: Int -> EndOfDaysException -> String -> String
$cshow :: EndOfDaysException -> String
show :: EndOfDaysException -> String
$cshowList :: [EndOfDaysException] -> String -> String
showList :: [EndOfDaysException] -> String -> String
Show

instance Exception EndOfDaysException