{-# 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
    { -- | Returns 'True' if the requested slot is already over
      forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
blockUntilSlot :: SlotNo -> m Bool

      -- | The current delay duration until the onset of the next slot
    , forall (m :: * -> *). OracularClock m -> m NominalDiffTime
delayUntilNextSlot :: m NominalDiffTime

      -- | A mock system time
      --
      -- Note that 'BTime.systemTimeCurrent' eventually raises
      -- 'EndOfDaysException'.
    , forall (m :: * -> *). OracularClock m -> SystemTime m
finiteSystemTime :: BTime.SystemTime m

      -- | The current slot
    , forall (m :: * -> *). OracularClock m -> m SlotNo
getCurrentSlot :: m SlotNo

      -- | See 'forkEachSlot'
    , forall (m :: * -> *).
OracularClock m
-> HasCallStack =>
   ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ :: HasCallStack
                    => ResourceRegistry m
                    -> String
                    -> (SlotNo -> m ())
                    -> m (m ())

      -- | Block until the clock is exhausted
    , forall (m :: * -> *). OracularClock m -> m ()
waitUntilDone :: m ()
    }

-- | 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 NominalDiffTime
now <- m RelativeTime
finiteSystemTimeCurrent
        let later :: NominalDiffTime
later = Future -> SlotNo -> NominalDiffTime
futureSlotToTime Future
future SlotNo
slot

        -- refuse to block until @>= endOfDays@
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
later NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
endOfDays) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ 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
endOfDays NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
now
          m ()
forall a. m a
exhaustedM

        NominalDiffTime -> NominalDiffTime -> m Bool
blockUntilTime NominalDiffTime
now NominalDiffTime
later

    , delayUntilNextSlot :: m NominalDiffTime
delayUntilNextSlot = do
        (SlotNo
_slot, NominalDiffTime
leftInSlot, SlotLength
_slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent
        NominalDiffTime -> m NominalDiffTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalDiffTime
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
        (SlotNo
slot, NominalDiffTime
_leftInSlot, SlotLength
_slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent
        SlotNo -> m SlotNo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotNo
slot

    , forkEachSlot_ :: HasCallStack =>
ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ = \ResourceRegistry m
rr String
threadLabel SlotNo -> m ()
action ->
        (Thread m Any -> m ()) -> m (Thread m Any) -> 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 Any -> m ()
forall (m :: * -> *) a. MonadAsync m => Thread m a -> m ()
cancelThread (m (Thread m Any) -> m (m ())) -> m (Thread m Any) -> m (m ())
forall a b. (a -> b) -> a -> b
$
        ResourceRegistry m -> String -> m Any -> m (Thread m Any)
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 Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$
        (m Any -> m Any) -> m Any
forall a. (a -> a) -> a
fix ((m Any -> m Any) -> m Any) -> (m Any -> m Any) -> m Any
forall a b. (a -> b) -> a -> b
$ \m Any
loop -> do
          -- INVARIANT the slot returned here ascends monotonically unless
          -- the underlying 'BTime.SystemTime' jumps backwards
          (SlotNo
slot, NominalDiffTime
leftInSlot, SlotLength
_slotLength) <- m (SlotNo, NominalDiffTime, SlotLength)
getPresent

          let lbl :: String
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
          m (Thread m ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m ()) -> m ()) -> m (Thread m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m () -> m (Thread m ())
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
rr String
lbl (m () -> m (Thread m ())) -> m () -> m (Thread m ())
forall a b. (a -> b) -> a -> b
$ SlotNo -> m ()
action SlotNo
slot

          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
leftInSlot
          m Any
loop

    , waitUntilDone :: m ()
waitUntilDone = do
        BTime.RelativeTime NominalDiffTime
now <- m RelativeTime
finiteSystemTimeCurrent
        m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> NominalDiffTime -> m Bool
blockUntilTime NominalDiffTime
now NominalDiffTime
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
        RelativeTime
t <- m RelativeTime
systemTimeCurrent

        -- check if clock is exhausted
        let tFinal :: RelativeTime
tFinal = NominalDiffTime -> RelativeTime
BTime.RelativeTime NominalDiffTime
endOfDays
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelativeTime
t RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
>  RelativeTime
tFinal) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ EndOfDaysException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO EndOfDaysException
EndOfDaysException
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RelativeTime
t RelativeTime -> RelativeTime -> Bool
forall a. Eq a => a -> a -> Bool
== RelativeTime
tFinal) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m ()
forall a. m a
exhaustedM

        RelativeTime -> m RelativeTime
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelativeTime
t

    getPresent :: m (SlotNo, NominalDiffTime, BTime.SlotLength)
    getPresent :: m (SlotNo, NominalDiffTime, SlotLength)
getPresent = do
        BTime.RelativeTime NominalDiffTime
now <- m RelativeTime
finiteSystemTimeCurrent
        (SlotNo, NominalDiffTime, SlotLength)
-> m (SlotNo, NominalDiffTime, SlotLength)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SlotNo, NominalDiffTime, SlotLength)
 -> m (SlotNo, NominalDiffTime, SlotLength))
-> (SlotNo, NominalDiffTime, SlotLength)
-> m (SlotNo, NominalDiffTime, SlotLength)
forall a b. (a -> b) -> a -> b
$ Future -> NominalDiffTime -> (SlotNo, NominalDiffTime, SlotLength)
futureTimeToSlot Future
future NominalDiffTime
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