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

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

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

data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs
  { HardForkBlockchainTimeArgs m blk -> m BackoffDelay
hfbtBackoffDelay   :: m BackoffDelay
    -- ^ See 'BackoffDelay'
  , HardForkBlockchainTimeArgs m blk -> STM m (LedgerState blk)
hfbtGetLedgerState :: STM m (LedgerState blk)
  , HardForkBlockchainTimeArgs m blk -> LedgerConfig blk
hfbtLedgerConfig   :: LedgerConfig blk
  , HardForkBlockchainTimeArgs m blk -> ResourceRegistry m
hfbtRegistry       :: ResourceRegistry m
  , HardForkBlockchainTimeArgs m blk -> SystemTime m
hfbtSystemTime     :: SystemTime m
  , HardForkBlockchainTimeArgs m blk
-> Tracer m (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer         :: Tracer m (TraceBlockchainTimeEvent RelativeTime)
  , HardForkBlockchainTimeArgs m blk -> NominalDiffTime
hfbtMaxClockRewind :: NominalDiffTime
    -- ^ Maximum time the clock can be rewound without throwing a fatal
    -- 'SystemClockMovedBack' exception.
    --
    -- When the slot length is short, e.g., Praos' 1s compared to PBFT's 20s,
    -- the chances of an NTP sync causing the clock to go back to the previous
    -- slot increase.
    --
    -- We allow the system clock to rewind up to 'hfbtMaxClockRewind', tracing a
    -- 'TraceSystemClockMovedBack' message in such cases. Note that the current
    -- slot *never decreases*, we just wait a bit longer in the same slot.
  }

-- | 'BlockchainTime' instance with support for the hard fork history
hardForkBlockchainTime :: forall m blk.
                          ( IOLike m
                          , HasHardForkHistory blk
                          , HasCallStack
                          )
                       => HardForkBlockchainTimeArgs m blk
                       -> m (BlockchainTime m)
hardForkBlockchainTime :: 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.
(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
-> 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 (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
    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 :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent :: m RelativeTime
systemTimeWait :: 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     -- Previous slot
         -> RelativeTime    -- Current time
         -> NominalDiffTime -- Time to wait until next slot
         -> m Void
    loop :: 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 (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
_)
            -- Unknown-to-known typically happens when syncing catches up far
            -- enough that we can now know what the current slot is.
            -> CurrentSlot -> m CurrentSlot
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
          (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.
            -> CurrentSlot -> m CurrentSlot
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
          (CurrentSlot
CurrentSlotUnknown, CurrentSlot
CurrentSlotUnknown)
            -> CurrentSlot -> m CurrentSlot
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
          (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.
            | SlotNo
m SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<  SlotNo
n
            -> CurrentSlot -> m CurrentSlot
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
            -- We could have @n == m@ or @n < m@ only if the user's system clock
            -- was adjusted (say by an NTP process). We only allow a limited
            -- rewinding of the clock, but never rewind the slot number
            | 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 (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
prevSlot
            | Bool
otherwise
            -> SystemClockMovedBackException -> m CurrentSlot
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

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

-- | Get current slot, current time, and the delay until the next slot.
getCurrentSlot' :: forall m xs. IOLike m
                => Tracer m (TraceBlockchainTimeEvent RelativeTime)
                -> SystemTime m
                -> HF.RunWithCachedSummary xs m
                -> m BackoffDelay
                -> m (CurrentSlot, RelativeTime, NominalDiffTime)
getCurrentSlot' :: 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
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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> CurrentSlot
CurrentSlot SlotNo
slot, RelativeTime
now, NominalDiffTime
timeLeft)