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

module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork (
    BackoffDelay (..)
  , HardForkBlockchainTimeArgs (..)
  , hardForkBlockchainTime
  ) where

import           Control.Monad
import           Control.ResourceRegistry
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.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
  { forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> m BackoffDelay
hfbtBackoffDelay   :: m BackoffDelay
    -- ^ See 'BackoffDelay'
  , forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> STM m (LedgerState blk EmptyMK)
hfbtGetLedgerState :: STM m (LedgerState blk EmptyMK)
  , forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> LedgerConfig blk
hfbtLedgerConfig   :: LedgerConfig blk
  , forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> ResourceRegistry m
hfbtRegistry       :: ResourceRegistry m
  , forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk -> SystemTime m
hfbtSystemTime     :: SystemTime m
  , forall (m :: * -> *) blk.
HardForkBlockchainTimeArgs m blk
-> Tracer m (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer         :: Tracer m (TraceBlockchainTimeEvent RelativeTime)
  , forall (m :: * -> *) blk.
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 :: forall (m :: * -> *) blk.
(IOLike m, HasHardForkHistory blk, HasCallStack) =>
HardForkBlockchainTimeArgs m blk -> m (BlockchainTime m)
hardForkBlockchainTime HardForkBlockchainTimeArgs m blk
args = do
    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 EmptyMK -> Summary (HardForkIndices blk)
summarize (LedgerState blk EmptyMK -> Summary (HardForkIndices blk))
-> STM m (LedgerState blk EmptyMK)
-> STM m (Summary (HardForkIndices blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (LedgerState blk EmptyMK)
getLedgerState)
    systemTimeWait

    (firstSlot, now, firstDelay) <- getCurrentSlot' tracer time run backoffDelay
    slotVar <- newTVarIO firstSlot
    void $ forkLinkedThread registry "hardForkBlockchainTime" $
             loop run slotVar firstSlot now firstDelay

    return $ BlockchainTime {
        getCurrentSlot = readTVar 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 EmptyMK)
hfbtGetLedgerState = STM m (LedgerState blk EmptyMK)
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 :: m ()
systemTimeCurrent :: m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
..}
      , 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 EmptyMK -> HF.Summary (HardForkIndices blk)
    summarize :: LedgerState blk EmptyMK -> Summary (HardForkIndices blk)
summarize LedgerState blk EmptyMK
st = LedgerConfig blk
-> LedgerState blk EmptyMK -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
cfg LedgerState blk EmptyMK
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 :: forall (xs :: [*]).
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)
           (newSlot, newTime, 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
           newSlot' <- checkValidClockChange (prevSlot, prevTime) (newSlot, newTime)
           atomically $ writeTVar slotVar newSlot'
           go newSlot' newTime 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 a. a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
newSlot
          (CurrentSlot
CurrentSlotUnknown, CurrentSlot
CurrentSlotUnknown)
            -> CurrentSlot -> m CurrentSlot
forall a. a -> m a
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 a. a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return CurrentSlot
prevSlot
            | Bool
otherwise
            -> SystemClockMovedBackException -> m CurrentSlot
forall e a. Exception e => e -> m a
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' :: 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 ()
m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
..} RunWithCachedSummary xs m
run m BackoffDelay
getBackoffDelay = do
    now   <- m RelativeTime
systemTimeCurrent
    mSlot <- atomically $ HF.cachedRunQuery run $ HF.wallclockToSlot now
    case 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 delay <- m BackoffDelay
getBackoffDelay
        return (CurrentSlotUnknown, now, delay)
      Right (SlotNo
slot, NominalDiffTime
_inSlot, NominalDiffTime
timeLeft) -> do
        (CurrentSlot, RelativeTime, NominalDiffTime)
-> m (CurrentSlot, RelativeTime, NominalDiffTime)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> CurrentSlot
CurrentSlot SlotNo
slot, RelativeTime
now, NominalDiffTime
timeLeft)