{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork (
    BackoffDelay (..),
    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

-- | A backoff delay
--
-- If the 'horizon' is very far away, the current tip is very far away from the
-- wallclock. However, that probably does not mean we have to wait @now -
-- horizon@ time: we are probably just syncing, and so the tip of the ledger
-- will rapidly move forward. So at most @now - horizon@ could be used as a
-- heuristic for how long to wait. For now we just trace it.
--
-- Instead, we just return a fixed delay of 'backoffDelay'. There is a
-- trade-off between trying to often, incurring computational overhead, and
-- missing the opportunity to produce a block. For mainnet, we anticipate a 60
-- second delay will keep both the computational overhead and the number of
-- slots we might miss reasonably small. We anyway can't guarantee the speed of
-- syncing, so delaying it by a further 60 seconds as needed does not change
-- anything fundamentally.
--
-- (NOTE: We could reduce this delay but Edsko doesn't think it would change
-- very much, and it would increase the frequency of the trace messages and
-- incur computational overhead.)
newtype BackoffDelay = BackoffDelay NominalDiffTime

-- | 'BlockchainTime' instance with support for the hard fork history
hardForkBlockchainTime :: forall m blk.
                          ( IOLike m
                          , HasHardForkHistory blk
                          , HasCallStack
                          )
                       => ResourceRegistry m
                       -> Tracer m (RelativeTime, HF.PastHorizonException)
                       -- ^ Tracer used when current slot is unknown
                       -> SystemTime m
                       -> LedgerConfig blk
                       -> m BackoffDelay
                       -> STM m (LedgerState blk)
                       -> m (BlockchainTime m)
hardForkBlockchainTime :: ResourceRegistry m
-> Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> LedgerConfig blk
-> m BackoffDelay
-> STM m (LedgerState blk)
-> m (BlockchainTime m)
hardForkBlockchainTime ResourceRegistry m
registry
                       Tracer m (RelativeTime, PastHorizonException)
tracer
                       time :: SystemTime m
time@SystemTime{m ()
m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: m RelativeTime
..}
                       LedgerConfig blk
cfg
                       m BackoffDelay
backoffDelay
                       STM m (LedgerState blk)
getLedgerState = 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, NominalDiffTime
firstDelay) <- Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> RunWithCachedSummary (HardForkIndices blk) m
-> m BackoffDelay
-> m (CurrentSlot, NominalDiffTime)
forall (m :: * -> *) (xs :: [*]).
IOLike m =>
Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, NominalDiffTime)
getCurrentSlot' Tracer m (RelativeTime, PastHorizonException)
tracer SystemTime m
time RunWithCachedSummary (HardForkIndices blk) m
run m BackoffDelay
backoffDelay
    StrictTVar m CurrentSlot
slotVar <- CurrentSlot -> m (StrictTVar m CurrentSlot)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, 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
-> NominalDiffTime
-> m Void
forall (xs :: [*]).
RunWithCachedSummary xs m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> NominalDiffTime
-> m Void
loop RunWithCachedSummary (HardForkIndices blk) m
run StrictTVar m CurrentSlot
slotVar CurrentSlot
firstSlot NominalDiffTime
firstDelay

    BlockchainTime m -> m (BlockchainTime m)
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 :: forall (m :: * -> *). STM m CurrentSlot -> BlockchainTime m
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
    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     -- Previous slot
         -> NominalDiffTime -- Time to wait until next slot
         -> m Void
    loop :: RunWithCachedSummary xs m
-> StrictTVar m CurrentSlot
-> CurrentSlot
-> NominalDiffTime
-> m Void
loop RunWithCachedSummary xs m
run StrictTVar m CurrentSlot
slotVar = CurrentSlot -> NominalDiffTime -> m Void
go
      where
        go :: CurrentSlot -> NominalDiffTime -> m Void
        go :: CurrentSlot -> NominalDiffTime -> m Void
go CurrentSlot
prevSlot NominalDiffTime
delay = do
           DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
delay)
           (CurrentSlot
newSlot, NominalDiffTime
newDelay) <- Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, NominalDiffTime)
forall (m :: * -> *) (xs :: [*]).
IOLike m =>
Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, NominalDiffTime)
getCurrentSlot' Tracer m (RelativeTime, PastHorizonException)
tracer SystemTime m
time RunWithCachedSummary xs m
run m BackoffDelay
backoffDelay
           (CurrentSlot, CurrentSlot) -> m ()
checkValidClockChange (CurrentSlot
prevSlot, CurrentSlot
newSlot)
           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 CurrentSlot -> CurrentSlot -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m CurrentSlot
slotVar CurrentSlot
newSlot
           CurrentSlot -> NominalDiffTime -> m Void
go CurrentSlot
newSlot NominalDiffTime
newDelay

    checkValidClockChange :: (CurrentSlot, CurrentSlot) -> m ()
    checkValidClockChange :: (CurrentSlot, CurrentSlot) -> m ()
checkValidClockChange = \case
        (CurrentSlot
CurrentSlotUnknown, CurrentSlot SlotNo
_) ->
          -- Unknown-to-known typically happens when syncing catches up far
          -- enough that we can now know what the current slot is.
          () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (CurrentSlot SlotNo
_, CurrentSlot
CurrentSlotUnknown) ->
          -- Known-to-unknown can happen when the ledger is no longer being
          -- updated and time marches on past the end of the safe zone.
          () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (CurrentSlot
CurrentSlotUnknown, CurrentSlot
CurrentSlotUnknown) ->
          () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (CurrentSlot SlotNo
m, CurrentSlot SlotNo
n)
          -- Normally we expect @n == m + 1@, but if the system is under heavy
          -- load, we might miss a slot. We could have @n == m@ only if the
          -- user's system clock was adjusted (say by an NTP process).
          | SlotNo
m SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<  SlotNo
n    -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | SlotNo
m SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
n    -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Bool
otherwise -> SystemClockMovedBackException -> m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (SystemClockMovedBackException -> m ())
-> SystemClockMovedBackException -> m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo -> SystemClockMovedBackException
SystemClockMovedBack SlotNo
m SlotNo
n

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Get current slot, and delay until next slot
getCurrentSlot' :: forall m xs. IOLike m
                => Tracer m (RelativeTime, HF.PastHorizonException)
                -> SystemTime m
                -> HF.RunWithCachedSummary xs m
                -> m BackoffDelay
                -> m (CurrentSlot, NominalDiffTime)
getCurrentSlot' :: Tracer m (RelativeTime, PastHorizonException)
-> SystemTime m
-> RunWithCachedSummary xs m
-> m BackoffDelay
-> m (CurrentSlot, NominalDiffTime)
getCurrentSlot' Tracer m (RelativeTime, PastHorizonException)
tracer SystemTime{m ()
m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
..} 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 (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
        -- give up for now and backoff; see 'BackoffDelay'
        Tracer m (RelativeTime, PastHorizonException)
-> (RelativeTime, PastHorizonException) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (RelativeTime, PastHorizonException)
tracer (RelativeTime
now, PastHorizonException
ex)
        BackoffDelay NominalDiffTime
delay <- m BackoffDelay
getBackoffDelay
        (CurrentSlot, NominalDiffTime) -> m (CurrentSlot, NominalDiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (CurrentSlot
CurrentSlotUnknown, NominalDiffTime
delay)
      Right (SlotNo
slot, NominalDiffTime
_inSlot, NominalDiffTime
timeLeft) -> do
        (CurrentSlot, NominalDiffTime) -> m (CurrentSlot, NominalDiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> CurrentSlot
CurrentSlot SlotNo
slot, NominalDiffTime
timeLeft)