{-# 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 Control.ResourceRegistry
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.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 ->
  -- | Max clock rewind
  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

  -- Fork thread that continuously updates the current slot
  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
  slotVar <- newTVarIO firstSlot
  void $
    forkLinkedThread registry "simpleBlockchainTime" $
      loop slotVar firstSlot

  -- The API is now a simple STM one
  return
    BlockchainTime
      { getCurrentSlot = CurrentSlot <$> readTVar 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
      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
      atomically $ writeTVar slotVar next
      go 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 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

{-------------------------------------------------------------------------------
  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 :: 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

-- | Wait until the next slot
--
-- Takes the current slot number to guard against system clock changes. If the
-- clock changes back further than the max clock rewind parameter, a fatal
-- 'SystemClockMovedBack' exception will be thrown. 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.
--
-- If the clock changed back less than the max clock rewind parameter, we stay
-- in the same slot for longer and don't throw an exception.
waitUntilNextSlot ::
  IOLike m =>
  SystemTime m ->
  SlotLength ->
  -- | Max clock rewind
  NominalDiffTime ->
  -- | Current slot number
  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
  now <- m RelativeTime
systemTimeCurrent

  let delay = SlotLength -> RelativeTime -> NominalDiffTime
delayUntilNextSlot SlotLength
slotLen RelativeTime
now
  threadDelay (nominalDelay 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, if the
  --   adjustment is <= the max rewind parameter, we allow it, but stay in the
  --   same slot. Just like the previous case, we will stay in one slot for
  --   longer.
  -- o If the system clock is adjusted back more than the max rewind
  --   parameter, we throw an exception (see discussion above).

  afterDelay <- systemTimeCurrent
  let (newCurrent, _timeInNewCurrent) = slotFromUTCTime slotLen afterDelay

  if
    | newCurrent > oldCurrent ->
        return newCurrent
    | newCurrent <= oldCurrent
    , now `diffRelTime` afterDelay <= maxClockRewind ->
        waitUntilNextSlot time slotLen maxClockRewind oldCurrent
    | otherwise ->
        throwIO $ SystemClockMovedBack oldCurrent newCurrent