{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.BlockchainTime.WallClock.Simple (
    simpleBlockchainTime
    -- * Low-level API (exported primarily for testing)
  , 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

-- | Real blockchain time
--
-- WARNING: if the start time is in the future, 'simpleBlockchainTime' will
-- block until the start time has come.
simpleBlockchainTime :: forall m. IOLike m
                     => ResourceRegistry m
                     -> SystemTime m
                     -> SlotLength
                     -> m (BlockchainTime m)
simpleBlockchainTime :: ResourceRegistry m
-> SystemTime m -> SlotLength -> m (BlockchainTime m)
simpleBlockchainTime ResourceRegistry m
registry SystemTime m
time SlotLength
slotLen = do
    SystemTime m -> m ()
forall (m :: * -> *). SystemTime m -> m ()
systemTimeWait SystemTime m
time

    -- Fork thread that continuously updates the current slot
    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.
(MonadSTM m, HasCallStack, 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

    -- The API is now a simple STM one
    BlockchainTime m -> m (BlockchainTime m)
forall (m :: * -> *) a. Monad m => a -> m a
return BlockchainTime :: forall (m :: * -> *). STM m CurrentSlot -> BlockchainTime m
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
    -- In each iteration of the loop, we recompute how long to wait until
    -- the next slot. This minimizes clock skew.
    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 -> SlotNo -> m SlotNo
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> SlotNo -> m SlotNo
waitUntilNextSlot SystemTime m
time SlotLength
slotLen SlotNo
current
          STM m () -> m ()
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

{-------------------------------------------------------------------------------
  Pure calculations
-------------------------------------------------------------------------------}

slotFromUTCTime :: SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime :: SlotLength -> RelativeTime -> (SlotNo, NominalDiffTime)
slotFromUTCTime SlotLength
slotLen (RelativeTime NominalDiffTime
now) =
    (Word64 -> SlotNo)
-> (Word64, NominalDiffTime) -> (SlotNo, NominalDiffTime)
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

{-------------------------------------------------------------------------------
  Stateful wrappers around the pure calculations
-------------------------------------------------------------------------------}

-- | Get current slot and time spent in that slot
getWallClockSlot :: IOLike m
                 => SystemTime m
                 -> SlotLength
                 -> m (SlotNo, NominalDiffTime)
getWallClockSlot :: SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
getWallClockSlot SystemTime{m ()
m RelativeTime
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
..} 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

-- | Wait until the next slot
--
-- Takes the current slot number to guard against system clock changes. Any
-- clock changes that would result in the slot number to /decrease/ will result
-- in a fatal 'SystemClockMovedBackException'. When this exception is thrown,
-- the node will shut down, and should be restarted with (full?) validation
-- enabled: it is conceivable that blocks got moved to the immutable DB that,
-- due to the clock change, should not be considered immutable anymore.
waitUntilNextSlot :: IOLike m
                  => SystemTime m
                  -> SlotLength
                  -> SlotNo    -- ^ Current slot number
                  -> m SlotNo
waitUntilNextSlot :: SystemTime m -> SlotLength -> SlotNo -> m SlotNo
waitUntilNextSlot 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 ()
..} SlotLength
slotLen 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)

    -- At this point we expect to be in 'nextSlot', but the actual now-current
    -- slot might be different:
    --
    -- o If the system is under heavy load, we might have missed some slots. If
    --   this is the case, that's okay, and we just report the actual
    --   now-current slot as the next slot.
    -- o If the system clock is adjusted back a tiny bit (maybe due to an NTP
    --   client running on the system), it's possible that we are still in the
    --   /old/ current slot. If this happens, we just wait again; nothing bad
    --   has happened, we just stay in one slot for longer.
    -- o If the system clock is adjusted back more than that, we might be in
    --   a slot number /before/ the old current slot. In that case, we throw
    --   an exception (see discussion above).

    (SlotNo
newCurrent, NominalDiffTime
_timeInNewCurrent) <- SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> m (SlotNo, NominalDiffTime)
getWallClockSlot SystemTime m
time SlotLength
slotLen

    if | SlotNo
newCurrent SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
oldCurrent ->
           SlotNo -> m SlotNo
forall (m :: * -> *) a. Monad m => a -> m a
return SlotNo
newCurrent
       | SlotNo
newCurrent SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
oldCurrent ->
           SystemTime m -> SlotLength -> SlotNo -> m SlotNo
forall (m :: * -> *).
IOLike m =>
SystemTime m -> SlotLength -> SlotNo -> m SlotNo
waitUntilNextSlot SystemTime m
time SlotLength
slotLen SlotNo
oldCurrent
       | Bool
otherwise ->
           SystemClockMovedBackException -> m SlotNo
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