{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.BlockchainTime.WallClock.Simple (
simpleBlockchainTime
, getWallClockSlot
, waitUntilNextSlot
) where
import Control.Monad
import Data.Bifunctor
import Data.Fixed (divMod')
import Data.Time (NominalDiffTime)
import Data.Void
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime.API
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
import Ouroboros.Consensus.BlockchainTime.WallClock.Util
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Consensus.Util.Time
simpleBlockchainTime :: forall m. IOLike m
=> ResourceRegistry m
-> SystemTime m
-> SlotLength
-> NominalDiffTime
-> m (BlockchainTime m)
simpleBlockchainTime :: forall (m :: * -> *).
IOLike m =>
ResourceRegistry m
-> SystemTime m
-> SlotLength
-> NominalDiffTime
-> m (BlockchainTime m)
simpleBlockchainTime ResourceRegistry m
registry SystemTime m
time SlotLength
slotLen NominalDiffTime
maxClockRewind = do
SystemTime m -> m ()
forall (m :: * -> *). SystemTime m -> m ()
systemTimeWait SystemTime m
time
SlotNo
firstSlot <- (SlotNo, NominalDiffTime) -> SlotNo
forall a b. (a, b) -> a
fst ((SlotNo, NominalDiffTime) -> SlotNo)
-> m (SlotNo, NominalDiffTime) -> m SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
getWallClockSlot SystemTime m
time SlotLength
slotLen
StrictTVar m SlotNo
slotVar <- SlotNo -> m (StrictTVar m SlotNo)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO SlotNo
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
"simpleBlockchainTime" (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
StrictTVar m SlotNo -> SlotNo -> m Void
loop StrictTVar m SlotNo
slotVar SlotNo
firstSlot
BlockchainTime m -> m (BlockchainTime m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockchainTime {
getCurrentSlot :: STM m CurrentSlot
getCurrentSlot = SlotNo -> CurrentSlot
CurrentSlot (SlotNo -> CurrentSlot) -> STM m SlotNo -> STM m CurrentSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m SlotNo -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m SlotNo
slotVar
}
where
loop :: StrictTVar m SlotNo
-> SlotNo
-> m Void
loop :: StrictTVar m SlotNo -> SlotNo -> m Void
loop StrictTVar m SlotNo
slotVar = SlotNo -> m Void
go
where
go :: SlotNo -> m Void
go :: SlotNo -> m Void
go SlotNo
current = do
SlotNo
next <- SystemTime m -> SlotLength -> NominalDiffTime -> SlotNo -> m SlotNo
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> NominalDiffTime -> SlotNo -> m SlotNo
waitUntilNextSlot SystemTime m
time SlotLength
slotLen NominalDiffTime
maxClockRewind SlotNo
current
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 SlotNo -> SlotNo -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m SlotNo
slotVar SlotNo
next
SlotNo -> m Void
go SlotNo
next
slotFromUTCTime :: SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime :: SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime SlotLength
slotLen (RelativeTime NominalDiffTime
now) =
(Word64 -> SlotNo)
-> (Word64, NominalDiffTime) -> (SlotNo, NominalDiffTime)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Word64 -> SlotNo
SlotNo ((Word64, NominalDiffTime) -> (SlotNo, NominalDiffTime))
-> (Word64, NominalDiffTime) -> (SlotNo, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ NominalDiffTime
now NominalDiffTime -> NominalDiffTime -> (Word64, NominalDiffTime)
forall a b. (Real a, Integral b) => a -> a -> (b, a)
`divMod'` SlotLength -> NominalDiffTime
getSlotLength SlotLength
slotLen
delayUntilNextSlot :: SlotLength -> RelativeTime -> NominalDiffTime
delayUntilNextSlot :: SlotLength -> RelativeTime -> NominalDiffTime
delayUntilNextSlot SlotLength
slotLen RelativeTime
now =
SlotLength -> NominalDiffTime
getSlotLength SlotLength
slotLen NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
timeSpent
where
(SlotNo
_curSlot, NominalDiffTime
timeSpent) = SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime SlotLength
slotLen RelativeTime
now
getWallClockSlot :: IOLike m
=> SystemTime m
-> SlotLength
-> m (SlotNo, NominalDiffTime)
getWallClockSlot :: forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
getWallClockSlot SystemTime{m ()
m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
..} SlotLength
slotLen =
SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime SlotLength
slotLen (RelativeTime -> (SlotNo, NominalDiffTime))
-> m RelativeTime -> m (SlotNo, NominalDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m RelativeTime
systemTimeCurrent
waitUntilNextSlot :: IOLike m
=> SystemTime m
-> SlotLength
-> NominalDiffTime
-> SlotNo
-> m SlotNo
waitUntilNextSlot :: forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> NominalDiffTime -> SlotNo -> m SlotNo
waitUntilNextSlot time :: SystemTime m
time@SystemTime{m ()
m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
..} SlotLength
slotLen NominalDiffTime
maxClockRewind SlotNo
oldCurrent = do
RelativeTime
now <- m RelativeTime
systemTimeCurrent
let delay :: NominalDiffTime
delay = SlotLength -> RelativeTime -> NominalDiffTime
delayUntilNextSlot SlotLength
slotLen RelativeTime
now
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
delay)
RelativeTime
afterDelay <- m RelativeTime
systemTimeCurrent
let (SlotNo
newCurrent, NominalDiffTime
_timeInNewCurrent) = SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime SlotLength
slotLen RelativeTime
afterDelay
if | SlotNo
newCurrent SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
oldCurrent ->
SlotNo -> m SlotNo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
newCurrent
| SlotNo
newCurrent SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
oldCurrent,
RelativeTime
now RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
afterDelay NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
maxClockRewind ->
SystemTime m -> SlotLength -> NominalDiffTime -> SlotNo -> m SlotNo
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> NominalDiffTime -> SlotNo -> m SlotNo
waitUntilNextSlot SystemTime m
time SlotLength
slotLen NominalDiffTime
maxClockRewind SlotNo
oldCurrent
| Bool
otherwise ->
SystemClockMovedBackException -> m SlotNo
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SystemClockMovedBackException -> m SlotNo)
-> SystemClockMovedBackException -> m SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> SystemClockMovedBackException
SystemClockMovedBack SlotNo
oldCurrent SlotNo
newCurrent