{-# 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 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 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
          (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