{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Util.HardFork.OracularClock (
EndOfDaysException (..)
, OracularClock (..)
, forkEachSlot
, mkOracularClock
) where
import Control.Monad (void, when)
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.ResourceRegistry
import Ouroboros.Consensus.Util.Time (nominalDelay)
import Test.Util.HardFork.Future (Future, futureSlotLengths,
futureSlotToTime, futureTimeToSlot)
import Test.Util.Slots (NumSlots (..))
data OracularClock m = OracularClock
{
forall (m :: * -> *). OracularClock m -> SlotNo -> m Bool
blockUntilSlot :: SlotNo -> m Bool
, forall (m :: * -> *). OracularClock m -> m NominalDiffTime
delayUntilNextSlot :: m NominalDiffTime
, forall (m :: * -> *). OracularClock m -> SystemTime m
finiteSystemTime :: BTime.SystemTime m
, forall (m :: * -> *). OracularClock m -> m SlotNo
getCurrentSlot :: m SlotNo
, forall (m :: * -> *).
OracularClock m
-> HasCallStack =>
ResourceRegistry m -> String -> (SlotNo -> m ()) -> m (m ())
forkEachSlot_ :: HasCallStack
=> ResourceRegistry m
-> String
-> (SlotNo -> m ())
-> m (m ())
, forall (m :: * -> *). OracularClock m -> m ()
waitUntilDone :: m ()
}
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
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
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. IOLike 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.
(IOLike 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
(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
"]"
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.
(IOLike 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
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
exhaustedM :: forall a. m a
exhaustedM :: forall a. m a
exhaustedM = do
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
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
finiteSystemTimeCurrent :: m BTime.RelativeTime
finiteSystemTimeCurrent :: m RelativeTime
finiteSystemTimeCurrent = do
RelativeTime
t <- m RelativeTime
systemTimeCurrent
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
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