{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork (
BackoffDelay (..)
, HardForkBlockchainTimeArgs (..)
, hardForkBlockchainTime
) where
import Control.Monad
import Control.Tracer
import Data.Time (NominalDiffTime)
import Data.Void
import GHC.Stack
import Ouroboros.Consensus.BlockchainTime.API
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
import Ouroboros.Consensus.BlockchainTime.WallClock.Util
import Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HF
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Consensus.Util.Time
newtype BackoffDelay = BackoffDelay NominalDiffTime
data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs
{ forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> m BackoffDelay
hfbtBackoffDelay :: m BackoffDelay
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> STM m (LedgerState blk)
hfbtGetLedgerState :: STM m (LedgerState blk)
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> LedgerConfig blk
hfbtLedgerConfig :: LedgerConfig blk
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> ResourceRegistry m
hfbtRegistry :: ResourceRegistry m
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> SystemTime m
hfbtSystemTime :: SystemTime m
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk
-> Tracer m (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer :: Tracer m (TraceBlockchainTimeEvent RelativeTime)
, forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> NominalDiffTime
hfbtMaxClockRewind :: NominalDiffTime
}
hardForkBlockchainTime :: forall m blk.
( IOLike m
, HasHardForkHistory blk
, HasCallStack
)
=> HardForkBlockchainTimeArgs m blk
-> m (BlockchainTime m)
hardForkBlockchainTime :: forall (m :: * -> *) blk.
(IOLike m, HasHardForkHistory blk, HasCallStack) =>
HardForkBlockchainTimeArgs m blk -> m (BlockchainTime m)
hardForkBlockchainTime HardForkBlockchainTimeArgs m blk
args = do
RunWithCachedSummary (HardForkIndices blk) m
run <- STM m (Summary (HardForkIndices blk))
-> m (RunWithCachedSummary (HardForkIndices blk) m)
forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
HF.runWithCachedSummary (LedgerState blk -> Summary (HardForkIndices blk)
summarize (LedgerState blk -> Summary (HardForkIndices blk))
-> STM m (LedgerState blk) -> STM m (Summary (HardForkIndices blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (LedgerState blk)
getLedgerState)
m ()
systemTimeWait
(CurrentSlot
firstSlot, RelativeTime
now, NominalDiffTime
firstDelay) <- Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> RunWithCachedSummary (HardForkIndices blk) m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
forall (m :: * -> *) (xs :: [*]).
IOLike m =>
Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
getCurrentSlot' Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer SystemTime m
time RunWithCachedSummary (HardForkIndices blk) m
run m BackoffDelay
backoffDelay
StrictTVar m CurrentSlot
slotVar <- CurrentSlot -> m (StrictTVar m CurrentSlot)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO CurrentSlot
firstSlot
m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"hardForkBlockchainTime" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
RunWithCachedSummary (HardForkIndices blk) m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> RelativeTime
-> NominalDiffTime
-> m Void
forall (xs :: [*]).
RunWithCachedSummary xs m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> RelativeTime
-> NominalDiffTime
-> m Void
loop RunWithCachedSummary (HardForkIndices blk) m
run StrictTVar m CurrentSlot
slotVar CurrentSlot
firstSlot RelativeTime
now NominalDiffTime
firstDelay
BlockchainTime m -> m (BlockchainTime m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockchainTime m -> m (BlockchainTime m))
-> BlockchainTime m -> m (BlockchainTime m)
forall a b. (a -> b) -> a -> b
$ BlockchainTime {
getCurrentSlot :: STM m CurrentSlot
getCurrentSlot = StrictTVar m CurrentSlot -> STM m CurrentSlot
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m CurrentSlot
slotVar
}
where
HardForkBlockchainTimeArgs
{ hfbtBackoffDelay :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> m BackoffDelay
hfbtBackoffDelay = m BackoffDelay
backoffDelay
, hfbtGetLedgerState :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> STM m (LedgerState blk)
hfbtGetLedgerState = STM m (LedgerState blk)
getLedgerState
, hfbtLedgerConfig :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> LedgerConfig blk
hfbtLedgerConfig = LedgerConfig blk
cfg
, hfbtRegistry :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> ResourceRegistry m
hfbtRegistry = ResourceRegistry m
registry
, hfbtSystemTime :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> SystemTime m
hfbtSystemTime = time :: SystemTime m
time@SystemTime{m ()
m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: m RelativeTime
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
..}
, hfbtTracer :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk
-> Tracer m (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer = Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer
, hfbtMaxClockRewind :: forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> NominalDiffTime
hfbtMaxClockRewind = NominalDiffTime
maxClockRewind
} = HardForkBlockchainTimeArgs m blk
args
summarize :: LedgerState blk -> HF.Summary (HardForkIndices blk)
summarize :: LedgerState blk -> Summary (HardForkIndices blk)
summarize LedgerState blk
st = LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
cfg LedgerState blk
st
loop :: HF.RunWithCachedSummary xs m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> RelativeTime
-> NominalDiffTime
-> m Void
loop :: forall (xs :: [*]).
RunWithCachedSummary xs m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> RelativeTime
-> NominalDiffTime
-> m Void
loop RunWithCachedSummary xs m
run StrictTVar m CurrentSlot
slotVar = CurrentSlot -> RelativeTime -> NominalDiffTime -> m Void
go
where
go :: CurrentSlot -> RelativeTime -> NominalDiffTime -> m Void
go :: CurrentSlot -> RelativeTime -> NominalDiffTime -> m Void
go CurrentSlot
prevSlot RelativeTime
prevTime NominalDiffTime
delay = do
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
delay)
(CurrentSlot
newSlot, RelativeTime
newTime, NominalDiffTime
newDelay) <- Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
forall (m :: * -> *) (xs :: [*]).
IOLike m =>
Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
getCurrentSlot' Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer SystemTime m
time RunWithCachedSummary xs m
run m BackoffDelay
backoffDelay
CurrentSlot
newSlot' <- (CurrentSlot, RelativeTime)
-> (CurrentSlot, RelativeTime) -> m CurrentSlot
checkValidClockChange (CurrentSlot
prevSlot, RelativeTime
prevTime) (CurrentSlot
newSlot, RelativeTime
newTime)
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m CurrentSlot -> CurrentSlot -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m CurrentSlot
slotVar CurrentSlot
newSlot'
CurrentSlot -> RelativeTime -> NominalDiffTime -> m Void
go CurrentSlot
newSlot' RelativeTime
newTime NominalDiffTime
newDelay
checkValidClockChange ::
(CurrentSlot, RelativeTime)
-> (CurrentSlot, RelativeTime)
-> m CurrentSlot
checkValidClockChange :: (CurrentSlot, RelativeTime)
-> (CurrentSlot, RelativeTime) -> m CurrentSlot
checkValidClockChange (CurrentSlot
prevSlot, RelativeTime
prevTime) (CurrentSlot
newSlot, RelativeTime
newTime) =
case (CurrentSlot
prevSlot, CurrentSlot
newSlot) of
(CurrentSlot
CurrentSlotUnknown, CurrentSlot SlotNo
_)
-> CurrentSlot -> m CurrentSlot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
(CurrentSlot SlotNo
_, CurrentSlot
CurrentSlotUnknown)
-> CurrentSlot -> m CurrentSlot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
(CurrentSlot
CurrentSlotUnknown, CurrentSlot
CurrentSlotUnknown)
-> CurrentSlot -> m CurrentSlot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
(CurrentSlot SlotNo
m, CurrentSlot SlotNo
n)
| SlotNo
m SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
n
-> CurrentSlot -> m CurrentSlot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
| SlotNo
m SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
n
, RelativeTime
prevTime RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
newTime NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
maxClockRewind
-> do Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> TraceBlockchainTimeEvent RelativeTime -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer (TraceBlockchainTimeEvent RelativeTime -> m ())
-> TraceBlockchainTimeEvent RelativeTime -> m ()
forall a b. (a -> b) -> a -> b
$ RelativeTime
-> RelativeTime -> TraceBlockchainTimeEvent RelativeTime
forall t. t -> t -> TraceBlockchainTimeEvent t
TraceSystemClockMovedBack RelativeTime
prevTime RelativeTime
newTime
CurrentSlot -> m CurrentSlot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
prevSlot
| Bool
otherwise
-> SystemClockMovedBackException -> m CurrentSlot
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SystemClockMovedBackException -> m CurrentSlot)
-> SystemClockMovedBackException -> m CurrentSlot
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> SystemClockMovedBackException
SystemClockMovedBack SlotNo
m SlotNo
n
getCurrentSlot' :: forall m xs. IOLike m
=> Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> HF.RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
getCurrentSlot' :: forall (m :: * -> *) (xs :: [*]).
IOLike m =>
Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
getCurrentSlot' Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer SystemTime{m ()
m RelativeTime
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
..} RunWithCachedSummary xs m
run m BackoffDelay
getBackoffDelay = do
RelativeTime
now <- m RelativeTime
systemTimeCurrent
Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime)
mSlot <- STM
m
(Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
-> m (Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
m
(Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
-> m (Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime)))
-> STM
m
(Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
-> m (Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
forall a b. (a -> b) -> a -> b
$ RunWithCachedSummary xs m
-> forall a. Qry a -> STM m (Either PastHorizonException a)
forall (xs :: [*]) (m :: * -> *).
RunWithCachedSummary xs m
-> forall a. Qry a -> STM m (Either PastHorizonException a)
HF.cachedRunQuery RunWithCachedSummary xs m
run (Qry (SlotNo, NominalDiffTime, NominalDiffTime)
-> STM
m
(Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime)))
-> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
-> STM
m
(Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime))
forall a b. (a -> b) -> a -> b
$ RelativeTime -> Qry (SlotNo, NominalDiffTime, NominalDiffTime)
HF.wallclockToSlot RelativeTime
now
case Either
PastHorizonException (SlotNo, NominalDiffTime, NominalDiffTime)
mSlot of
Left PastHorizonException
ex -> do
Tracer m (TraceBlockchainTimeEvent RelativeTime)
-> TraceBlockchainTimeEvent RelativeTime -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceBlockchainTimeEvent RelativeTime)
tracer (TraceBlockchainTimeEvent RelativeTime -> m ())
-> TraceBlockchainTimeEvent RelativeTime -> m ()
forall a b. (a -> b) -> a -> b
$ RelativeTime
-> PastHorizonException -> TraceBlockchainTimeEvent RelativeTime
forall t. t -> PastHorizonException -> TraceBlockchainTimeEvent t
TraceCurrentSlotUnknown RelativeTime
now PastHorizonException
ex
BackoffDelay NominalDiffTime
delay <- m BackoffDelay
getBackoffDelay
(CurrentSlot, RelativeTime, NominalDiffTime)
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CurrentSlot
CurrentSlotUnknown, RelativeTime
now, NominalDiffTime
delay)
Right (SlotNo
slot, NominalDiffTime
_inSlot, NominalDiffTime
timeLeft) -> do
(CurrentSlot, RelativeTime, NominalDiffTime)
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> CurrentSlot
CurrentSlot SlotNo
slot, RelativeTime
now, NominalDiffTime
timeLeft)