{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

-- | The Genesis State Machine decides whether the node is caught-up or not.
module Ouroboros.Consensus.Node.GSM (
    CandidateVersusSelection (..)
  , DurationFromNow (..)
  , GsmEntryPoints (..)
  , GsmNodeKernelArgs (..)
  , GsmState (..)
  , GsmView (..)
  , MarkerFileView (..)
  , WrapDurationUntilTooOld (..)
    -- * Auxiliaries
  , TraceGsmEvent (..)
  , gsmStateToLedgerJudgement
  , initializationGsmState
    -- * Constructors
  , realDurationUntilTooOld
  , realGsmEntryPoints
  , realMarkerFileView
    -- * Re-exported
  , module Ouroboros.Consensus.Node.GsmState
  ) where

import           Cardano.Network.Types (LedgerStateJudgement (..))
import qualified Cardano.Slotting.Slot as Slot
import qualified Control.Concurrent.Class.MonadSTM.TVar as LazySTM
import           Control.Monad (forever, join, unless)
import           Control.Monad.Class.MonadSTM (MonadSTM, STM, atomically, check,
                     orElse)
import           Control.Monad.Class.MonadThrow (MonadThrow)
import           Control.Monad.Class.MonadTimer (threadDelay)
import qualified Control.Monad.Class.MonadTimer.SI as SI
import           Control.Tracer (Tracer, traceWith)
import           Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import           Data.Time (NominalDiffTime)
import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Clock
import qualified Ouroboros.Consensus.HardFork.Abstract as HardFork
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import qualified Ouroboros.Consensus.Ledger.Basics as L
import           Ouroboros.Consensus.Node.GsmState
import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import           Ouroboros.Consensus.Util.NormalForm.StrictTVar (StrictTVar)
import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as StrictSTM
import           System.FS.API (HasFS, createDirectoryIfMissing, doesFileExist,
                     removeFile, withFile)
import           System.FS.API.Types (AllowExisting (..), FsPath, OpenMode (..),
                     mkFsPath)
import           System.Random (StdGen, uniformR)

{-------------------------------------------------------------------------------
  Interface
-------------------------------------------------------------------------------}

data DurationFromNow =
    After !NominalDiffTime
    -- ^ INVARIANT positive
  |
    Already
    -- ^ This value represents all non-positive durations, ie events from the
    -- past
  deriving (DurationFromNow -> DurationFromNow -> Bool
(DurationFromNow -> DurationFromNow -> Bool)
-> (DurationFromNow -> DurationFromNow -> Bool)
-> Eq DurationFromNow
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DurationFromNow -> DurationFromNow -> Bool
== :: DurationFromNow -> DurationFromNow -> Bool
$c/= :: DurationFromNow -> DurationFromNow -> Bool
/= :: DurationFromNow -> DurationFromNow -> Bool
Eq, Int -> DurationFromNow -> ShowS
[DurationFromNow] -> ShowS
DurationFromNow -> String
(Int -> DurationFromNow -> ShowS)
-> (DurationFromNow -> String)
-> ([DurationFromNow] -> ShowS)
-> Show DurationFromNow
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DurationFromNow -> ShowS
showsPrec :: Int -> DurationFromNow -> ShowS
$cshow :: DurationFromNow -> String
show :: DurationFromNow -> String
$cshowList :: [DurationFromNow] -> ShowS
showList :: [DurationFromNow] -> ShowS
Show)

data CandidateVersusSelection =
    CandidateDoesNotIntersect
    -- ^ The GSM assumes that this is ephemeral
    --
    -- For example, the ChainSync client will either disconnect from the peer
    -- or update the candidate to one that is not stale. It's also technically
    -- possible that the selection is stale, which the ChainDB would also
    -- resolve as soon as possible.
  |
    WhetherCandidateIsBetter !Bool
    -- ^ Whether the candidate is better than the selection
  deriving (CandidateVersusSelection -> CandidateVersusSelection -> Bool
(CandidateVersusSelection -> CandidateVersusSelection -> Bool)
-> (CandidateVersusSelection -> CandidateVersusSelection -> Bool)
-> Eq CandidateVersusSelection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CandidateVersusSelection -> CandidateVersusSelection -> Bool
== :: CandidateVersusSelection -> CandidateVersusSelection -> Bool
$c/= :: CandidateVersusSelection -> CandidateVersusSelection -> Bool
/= :: CandidateVersusSelection -> CandidateVersusSelection -> Bool
Eq, Int -> CandidateVersusSelection -> ShowS
[CandidateVersusSelection] -> ShowS
CandidateVersusSelection -> String
(Int -> CandidateVersusSelection -> ShowS)
-> (CandidateVersusSelection -> String)
-> ([CandidateVersusSelection] -> ShowS)
-> Show CandidateVersusSelection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CandidateVersusSelection -> ShowS
showsPrec :: Int -> CandidateVersusSelection -> ShowS
$cshow :: CandidateVersusSelection -> String
show :: CandidateVersusSelection -> String
$cshowList :: [CandidateVersusSelection] -> ShowS
showList :: [CandidateVersusSelection] -> ShowS
Show)

data GsmView m upstreamPeer selection chainSyncState = GsmView {
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> Maybe StdGen
antiThunderingHerd        :: Maybe StdGen
    -- ^ An initial seed used to randomly increase 'minCaughtUpDuration' by up
    -- to 15% every transition from Syncing to CaughtUp, in order to avoid a
    -- thundering herd phenomenon.
    --
    -- 'Nothing' should only be used for testing.
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> selection -> chainSyncState -> CandidateVersusSelection
candidateOverSelection    ::
        selection -> chainSyncState -> CandidateVersusSelection
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> chainSyncState -> Bool
peerIsIdle                :: chainSyncState -> Bool
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> Maybe (selection -> m DurationFromNow)
durationUntilTooOld       :: Maybe (selection -> m DurationFromNow)
    -- ^ How long from now until the selection will be so old that the node
    -- should exit the @CaughtUp@ state
    --
    -- 'Nothing' means the selection can never become too old.
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> selection -> selection -> Bool
equivalent                :: selection -> selection -> Bool
    -- ^ Whether the two selections are equivalent for the purpose of the
    -- Genesis State Machine
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> STM m (Map upstreamPeer (StrictTVar m chainSyncState))
getChainSyncStates        ::
        STM m (Map.Map upstreamPeer (StrictTVar m chainSyncState))
    -- ^ The current ChainSync state with the latest candidates from the
    -- upstream peers
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> STM m selection
getCurrentSelection       :: STM m selection
    -- ^ The node's current selection
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> NominalDiffTime
minCaughtUpDuration       :: NominalDiffTime
    -- ^ How long the node must stay in CaughtUp after transitioning to it from
    -- Syncing, regardless of the selection's age. This prevents the whole
    -- network from thrashing between CaughtUp and (Pre)Syncing if there's an
    -- outage in block production.
    --
    -- See also 'antiThunderingHerd'.
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> Bool -> m ()
setCaughtUpPersistentMark :: Bool -> m ()
    -- ^ EG touch/delete the marker file on disk
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> GsmState -> m ()
writeGsmState             :: GsmState -> m ()
    -- ^ EG update the TVar that the Diffusion Layer monitors, or en-/disable
    -- certain components of Genesis
  ,
    forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> STM m Bool
isHaaSatisfied            :: STM m Bool
    -- ^ Whether the Honest Availability Assumption is currently satisfied. This
    -- is used as the trigger for transitioning from 'PreSyncing' to 'Syncing'
    -- and vice versa.
  }

-- | The two proper GSM entrypoints.
--
-- See the @BootstrapPeersIER.md@ document for documentation.
--
-- See 'initializationLedgerJudgement' for the @Initializing@ pseudo-state.
data GsmEntryPoints m = GsmEntryPoints {
    forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
enterCaughtUp   :: forall neverTerminates. m neverTerminates
    -- ^ ASSUMPTION the marker file is present on disk, a la
    -- @'setCaughtUpPersistentMark' True@
    --
    -- Thus this can be invoked at node start up after determining the marker
    -- file is present (and the tip is still not stale)
  ,
    forall (m :: * -> *).
GsmEntryPoints m -> forall neverTerminates. m neverTerminates
enterPreSyncing :: forall neverTerminates. m neverTerminates
    -- ^ ASSUMPTION the marker file is absent on disk, a la
    -- @'setCaughtUpPersistentMark' False@
    --
    -- Thus this can be invoked at node start up after determining the marker
    -- file is absent.
  }

-----

-- | Determine the initial 'GsmState'
--
-- Also initializes the persistent marker file.
initializationGsmState ::
     ( L.GetTip (L.LedgerState blk)
     , Monad m
     )
  => m (L.LedgerState blk L.EmptyMK)
  -> Maybe (WrapDurationUntilTooOld m blk)
     -- ^ 'Nothing' if @blk@ has no age limit
  -> MarkerFileView m
  -> m GsmState
initializationGsmState :: forall blk (m :: * -> *).
(GetTip (LedgerState blk), Monad m) =>
m (LedgerState blk EmptyMK)
-> Maybe (WrapDurationUntilTooOld m blk)
-> MarkerFileView m
-> m GsmState
initializationGsmState
    m (LedgerState blk EmptyMK)
getCurrentLedger
    Maybe (WrapDurationUntilTooOld m blk)
mbDurationUntilTooOld
    MarkerFileView m
markerFileView
  = do
    wasCaughtUp <- MarkerFileView m -> m Bool
forall (m :: * -> *). MarkerFileView m -> m Bool
hasMarkerFile MarkerFileView m
markerFileView
    if not wasCaughtUp then pure PreSyncing else do
        case mbDurationUntilTooOld of
            Maybe (WrapDurationUntilTooOld m blk)
Nothing -> GsmState -> m GsmState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GsmState
CaughtUp
            Just WrapDurationUntilTooOld m blk
wd -> do
                sno <- LedgerState blk EmptyMK -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
L.getTipSlot (LedgerState blk EmptyMK -> WithOrigin SlotNo)
-> m (LedgerState blk EmptyMK) -> m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LedgerState blk EmptyMK)
getCurrentLedger
                getDurationUntilTooOld wd sno >>= \case
                    After{}     -> GsmState -> m GsmState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GsmState
CaughtUp
                    DurationFromNow
Already     -> do
                        MarkerFileView m -> m ()
forall (m :: * -> *). MarkerFileView m -> m ()
removeMarkerFile MarkerFileView m
markerFileView
                        GsmState -> m GsmState
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GsmState
PreSyncing

-- | For 'LedgerStateJudgement' as used in the Diffusion layer, there is no
-- difference between 'PreSyncing' and 'Syncing'.
gsmStateToLedgerJudgement :: GsmState -> LedgerStateJudgement
gsmStateToLedgerJudgement :: GsmState -> LedgerStateJudgement
gsmStateToLedgerJudgement = \case
    GsmState
PreSyncing -> LedgerStateJudgement
TooOld
    GsmState
Syncing    -> LedgerStateJudgement
TooOld
    GsmState
CaughtUp   -> LedgerStateJudgement
YoungEnough

{-------------------------------------------------------------------------------
  A real implementation
-------------------------------------------------------------------------------}

-- | The actual GSM logic for boot strap peers
--
-- See the @BootstrapPeersIER.md@ document for the specification of most of this
-- logic, except the transition rules between PreSyncing and Syncing, the two
-- states OnlyBootstrap is split into:
--
--  - PreSyncing ⟶ Syncing: The Honest Availability Assumption is satisfied.
--
--- - Syncing ⟶ PreSyncing: The Honest Availability Assumption is no longer
---   satisfied.
realGsmEntryPoints :: forall m upstreamPeer selection tracedSelection candidate.
     ( SI.MonadDelay m
     , SI.MonadTimer m
     )
  => (selection -> tracedSelection, Tracer m (TraceGsmEvent tracedSelection))
  -> GsmView m upstreamPeer selection candidate
  -> GsmEntryPoints m
realGsmEntryPoints :: forall (m :: * -> *) upstreamPeer selection tracedSelection
       candidate.
(MonadDelay m, MonadTimer m) =>
(selection -> tracedSelection,
 Tracer m (TraceGsmEvent tracedSelection))
-> GsmView m upstreamPeer selection candidate -> GsmEntryPoints m
realGsmEntryPoints (selection -> tracedSelection,
 Tracer m (TraceGsmEvent tracedSelection))
tracerArgs GsmView m upstreamPeer selection candidate
gsmView = GsmEntryPoints {
    m neverTerminates
forall neverTerminates. m neverTerminates
enterCaughtUp :: forall neverTerminates. m neverTerminates
enterCaughtUp :: forall neverTerminates. m neverTerminates
enterCaughtUp
  ,
    m neverTerminates
forall neverTerminates. m neverTerminates
enterPreSyncing :: forall neverTerminates. m neverTerminates
enterPreSyncing :: forall neverTerminates. m neverTerminates
enterPreSyncing
  }
  where
    (selection -> tracedSelection
cnvSelection, Tracer m (TraceGsmEvent tracedSelection)
tracer) = (selection -> tracedSelection,
 Tracer m (TraceGsmEvent tracedSelection))
tracerArgs

    GsmView {
        Maybe StdGen
antiThunderingHerd :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> Maybe StdGen
antiThunderingHerd :: Maybe StdGen
antiThunderingHerd
      ,
        selection -> candidate -> CandidateVersusSelection
candidateOverSelection :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> selection -> chainSyncState -> CandidateVersusSelection
candidateOverSelection :: selection -> candidate -> CandidateVersusSelection
candidateOverSelection
      ,
        candidate -> Bool
peerIsIdle :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> chainSyncState -> Bool
peerIsIdle :: candidate -> Bool
peerIsIdle
      ,
        Maybe (selection -> m DurationFromNow)
durationUntilTooOld :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> Maybe (selection -> m DurationFromNow)
durationUntilTooOld :: Maybe (selection -> m DurationFromNow)
durationUntilTooOld
      ,
        selection -> selection -> Bool
equivalent :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> selection -> selection -> Bool
equivalent :: selection -> selection -> Bool
equivalent
      ,
        STM m (Map upstreamPeer (StrictTVar m candidate))
getChainSyncStates :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState
-> STM m (Map upstreamPeer (StrictTVar m chainSyncState))
getChainSyncStates :: STM m (Map upstreamPeer (StrictTVar m candidate))
getChainSyncStates
      ,
        STM m selection
getCurrentSelection :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> STM m selection
getCurrentSelection :: STM m selection
getCurrentSelection
      ,
        NominalDiffTime
minCaughtUpDuration :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> NominalDiffTime
minCaughtUpDuration :: NominalDiffTime
minCaughtUpDuration
      ,
        Bool -> m ()
setCaughtUpPersistentMark :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> Bool -> m ()
setCaughtUpPersistentMark :: Bool -> m ()
setCaughtUpPersistentMark
      ,
        GsmState -> m ()
writeGsmState :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> GsmState -> m ()
writeGsmState :: GsmState -> m ()
writeGsmState
      ,
        STM m Bool
isHaaSatisfied :: forall (m :: * -> *) upstreamPeer selection chainSyncState.
GsmView m upstreamPeer selection chainSyncState -> STM m Bool
isHaaSatisfied :: STM m Bool
isHaaSatisfied
      } = GsmView m upstreamPeer selection candidate
gsmView

    enterCaughtUp :: forall neverTerminates. m neverTerminates
    enterCaughtUp :: forall neverTerminates. m neverTerminates
enterCaughtUp  = Maybe StdGen -> m neverTerminates
forall neverTerminates. Maybe StdGen -> m neverTerminates
enterCaughtUp' Maybe StdGen
antiThunderingHerd

    enterPreSyncing :: forall neverTerminates. m neverTerminates
    enterPreSyncing :: forall neverTerminates. m neverTerminates
enterPreSyncing = Maybe StdGen -> forall neverTerminates. m neverTerminates
enterPreSyncing' Maybe StdGen
antiThunderingHerd

    enterCaughtUp' :: forall neverTerminates. Maybe StdGen -> m neverTerminates
    enterCaughtUp' :: forall neverTerminates. Maybe StdGen -> m neverTerminates
enterCaughtUp' Maybe StdGen
g = do
        (g', ev) <- Maybe StdGen -> m (Maybe StdGen, TraceGsmEvent tracedSelection)
blockWhileCaughtUp Maybe StdGen
g

        setCaughtUpPersistentMark False
        writeGsmState PreSyncing
        traceWith tracer ev

        enterPreSyncing' g'

    enterPreSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
    enterPreSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
enterPreSyncing' Maybe StdGen
g = do
        m ()
blockUntilHonestAvailabilityAssumption

        GsmState -> m ()
writeGsmState GsmState
Syncing
        Tracer m (TraceGsmEvent tracedSelection)
-> TraceGsmEvent tracedSelection -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceGsmEvent tracedSelection)
tracer TraceGsmEvent tracedSelection
forall selection. TraceGsmEvent selection
GsmEventPreSyncingToSyncing

        Maybe StdGen -> forall neverTerminates. m neverTerminates
enterSyncing' Maybe StdGen
g

    enterSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
    enterSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
enterSyncing' Maybe StdGen
g = do
        -- Wait until either the Honest Availability Assumption is no longer
        -- satisfied, or we are caught up.
        mev <- STM m (Maybe (TraceGsmEvent tracedSelection))
-> m (Maybe (TraceGsmEvent tracedSelection))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (TraceGsmEvent tracedSelection))
 -> m (Maybe (TraceGsmEvent tracedSelection)))
-> STM m (Maybe (TraceGsmEvent tracedSelection))
-> m (Maybe (TraceGsmEvent tracedSelection))
forall a b. (a -> b) -> a -> b
$
          (Maybe (TraceGsmEvent tracedSelection)
forall a. Maybe a
Nothing Maybe (TraceGsmEvent tracedSelection)
-> STM m () -> STM m (Maybe (TraceGsmEvent tracedSelection))
forall a b. a -> STM m b -> STM m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ STM m ()
blockWhileHonestAvailabilityAssumption)
            STM m (Maybe (TraceGsmEvent tracedSelection))
-> STM m (Maybe (TraceGsmEvent tracedSelection))
-> STM m (Maybe (TraceGsmEvent tracedSelection))
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
`orElse`
          (TraceGsmEvent tracedSelection
-> Maybe (TraceGsmEvent tracedSelection)
forall a. a -> Maybe a
Just    (TraceGsmEvent tracedSelection
 -> Maybe (TraceGsmEvent tracedSelection))
-> STM m (TraceGsmEvent tracedSelection)
-> STM m (Maybe (TraceGsmEvent tracedSelection))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (TraceGsmEvent tracedSelection)
blockUntilCaughtUp)

        case mev of
          Maybe (TraceGsmEvent tracedSelection)
Nothing  -> do
            GsmState -> m ()
writeGsmState GsmState
PreSyncing
            Tracer m (TraceGsmEvent tracedSelection)
-> TraceGsmEvent tracedSelection -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceGsmEvent tracedSelection)
tracer TraceGsmEvent tracedSelection
forall selection. TraceGsmEvent selection
GsmEventSyncingToPreSyncing

            Maybe StdGen -> forall neverTerminates. m neverTerminates
enterPreSyncing' Maybe StdGen
g
          Just TraceGsmEvent tracedSelection
ev -> do
            GsmState -> m ()
writeGsmState GsmState
CaughtUp
            Bool -> m ()
setCaughtUpPersistentMark Bool
True
            Tracer m (TraceGsmEvent tracedSelection)
-> TraceGsmEvent tracedSelection -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceGsmEvent tracedSelection)
tracer TraceGsmEvent tracedSelection
ev

            -- When transitioning from Syncing to CaughtUp, the node will remain
            -- in CaughtUp for at least 'minCaughtUpDuration', regardless of the
            -- selection's age.
            DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
SI.threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
minCaughtUpDuration

            Maybe StdGen -> m neverTerminates
forall neverTerminates. Maybe StdGen -> m neverTerminates
enterCaughtUp' Maybe StdGen
g

    blockWhileCaughtUp ::
         Maybe StdGen
      -> m (Maybe StdGen, TraceGsmEvent tracedSelection)
    blockWhileCaughtUp :: Maybe StdGen -> m (Maybe StdGen, TraceGsmEvent tracedSelection)
blockWhileCaughtUp Maybe StdGen
g = do
        -- Randomly add up to 5min.
        --
        -- Under the ideal circumstances, nodes have perfectly synchronized
        -- clocks. However, if there's a block production outage, that means
        -- /all/ nodes will switch back to the bootstrap peers
        -- /simultaneously/, incurring a thundering herd of requests on that
        -- relatively small population. This random change will spread that
        -- load out.
        --
        -- TODO should the Diffusion Layer do this? IE the node /promptly/
        -- switches to PreSyncing, but then the Diffusion Layer introces a delay
        -- before reaching out to the bootstrap peers?
        let (DiffTime
bonus, Maybe StdGen
g') = case Maybe StdGen
g of
                Maybe StdGen
Nothing -> (DiffTime
0, Maybe StdGen
forall a. Maybe a
Nothing)   -- it's disabled in some tests
                Just StdGen
x  ->
                    let (Int
seconds, !StdGen
g'') =
                            (Int, Int) -> StdGen -> (Int, StdGen)
forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (Int
0, Int
300 :: Int) StdGen
x
                    in
                    (Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
seconds, StdGen -> Maybe StdGen
forall a. a -> Maybe a
Just StdGen
g'')

        ev <- STM m selection -> m selection
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m selection
getCurrentSelection m selection
-> (selection -> m (TraceGsmEvent tracedSelection))
-> m (TraceGsmEvent tracedSelection)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DiffTime -> selection -> m (TraceGsmEvent tracedSelection)
blockWhileCaughtUpHelper DiffTime
bonus

        pure (g', ev)

    blockWhileCaughtUpHelper ::
         SI.DiffTime
      -> selection
      -> m (TraceGsmEvent tracedSelection)
    blockWhileCaughtUpHelper :: DiffTime -> selection -> m (TraceGsmEvent tracedSelection)
blockWhileCaughtUpHelper DiffTime
bonus selection
selection = do
        let tracedSelection :: tracedSelection
tracedSelection = selection -> tracedSelection
cnvSelection selection
selection

            computeDuration :: m (Maybe DurationFromNow)
            computeDuration :: m (Maybe DurationFromNow)
computeDuration = ((selection -> m DurationFromNow) -> m DurationFromNow)
-> Maybe (selection -> m DurationFromNow)
-> m (Maybe DurationFromNow)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM ((selection -> m DurationFromNow) -> selection -> m DurationFromNow
forall a b. (a -> b) -> a -> b
$ selection
selection) Maybe (selection -> m DurationFromNow)
durationUntilTooOld
        m (Maybe DurationFromNow)
computeDuration m (Maybe DurationFromNow)
-> (Maybe DurationFromNow -> m (TraceGsmEvent tracedSelection))
-> m (TraceGsmEvent tracedSelection)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe DurationFromNow
Nothing          -> m () -> m (TraceGsmEvent tracedSelection)
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m (TraceGsmEvent tracedSelection))
-> m () -> m (TraceGsmEvent tracedSelection)
forall a b. (a -> b) -> a -> b
$ Int -> m ()
forall (m :: * -> *). MonadDelay m => Int -> m ()
threadDelay Int
forall a. Bounded a => a
maxBound
            Just DurationFromNow
Already     -> do   -- it's already too old
                TraceGsmEvent tracedSelection -> m (TraceGsmEvent tracedSelection)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceGsmEvent tracedSelection
 -> m (TraceGsmEvent tracedSelection))
-> TraceGsmEvent tracedSelection
-> m (TraceGsmEvent tracedSelection)
forall a b. (a -> b) -> a -> b
$ tracedSelection -> DurationFromNow -> TraceGsmEvent tracedSelection
forall selection.
selection -> DurationFromNow -> TraceGsmEvent selection
GsmEventLeaveCaughtUp tracedSelection
tracedSelection DurationFromNow
Already
            Just (After NominalDiffTime
dur) -> do
                varTimeoutExpired <- DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
SI.registerDelay (NominalDiffTime -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
dur DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
bonus)

                -- If the selection changes before the timeout expires, loop to
                -- setup a new timeout for the new tip.
                --
                -- Otherwise the timeout expired before the selection changed
                -- (or they both happened after the previous attempt of this
                -- STM transaction), so the node is no longer in @CaughtUp@.
                join $ atomically $ do
                    expired <- LazySTM.readTVar varTimeoutExpired
                    let ev = tracedSelection -> DurationFromNow -> TraceGsmEvent tracedSelection
forall selection.
selection -> DurationFromNow -> TraceGsmEvent selection
GsmEventLeaveCaughtUp tracedSelection
tracedSelection (NominalDiffTime -> DurationFromNow
After NominalDiffTime
dur)
                    if expired then pure (pure ev) else do
                        selection' <- getCurrentSelection
                        check $ not $ equivalent selection selection'
                        pure $ blockWhileCaughtUpHelper bonus selection'

    blockUntilCaughtUp :: STM m (TraceGsmEvent tracedSelection)
    blockUntilCaughtUp :: STM m (TraceGsmEvent tracedSelection)
blockUntilCaughtUp = do
        -- STAGE 1: all ChainSync clients report no subsequent headers
        varsState     <- STM m (Map upstreamPeer (StrictTVar m candidate))
getChainSyncStates
        states        <- traverse StrictSTM.readTVar varsState
        check $
             not (Map.null states)
          && all peerIsIdle states

        -- STAGE 2: no candidate is better than the node's current
        -- selection
        --
        -- For the Bootstrap State Machine, it's fine to completely ignore
        -- block diffusion pipelining here, because all bootstrap peers will
        -- /promptly/ rollback the tentative header if its block body turns out
        -- to be invalid (aka /trap header/). Thus the node will stay in
        -- CaughtUp slighty longer, until the system is no longer pipelining a
        -- block; general Praos reasoning ensures that won't take particularly
        -- long.
        selection  <- getCurrentSelection
        candidates <- traverse StrictSTM.readTVar varsState
        let ok candidate
candidate =
                Bool -> CandidateVersusSelection
WhetherCandidateIsBetter Bool
False
             CandidateVersusSelection -> CandidateVersusSelection -> Bool
forall a. Eq a => a -> a -> Bool
== selection -> candidate -> CandidateVersusSelection
candidateOverSelection selection
selection candidate
candidate
        check $ all ok candidates

        pure $ GsmEventEnterCaughtUp
            (Map.size states)
            (cnvSelection selection)

        -- STAGE 3: the previous stages weren't so slow that the idler
        -- set/candidate set/individual candidates changed
        --
        -- At this point, the STM scheduler will automatically retry this
        -- transaction if and only if any of the TVars are no longer
        -- pointer-equal to what was read above. That outcome is unlikely as
        -- long as there are not a huge number of peers; as Simon Marlow wrote,
        -- "Never read an unbounded number of TVars in a single transaction
        -- because the O(n) performance of readTVar then gives O(n*n) for the
        -- whole transaction."
        --
        -- (NSF: I peeked at ghc/rts/STM.c today. The thing being counted by
        -- the O(n*n) notation in the quote above is iterations of a C for loop
        -- that reads a C array. The transaction log is a linked list of
        -- chunks, each a 16 element array. So the 4 node kernel tvars + one
        -- tvar for each of the first 12 peers fill up the first chunk, and
        -- then there's a new chunk for each group of 16 peers beyond that. For
        -- example, 44 peers would exactly fill 3 chunks. Thus, each readTVar
        -- pages in at most 4 VM pages for the number of peers we're
        -- anticipating. And then the STM validation at the end touches them
        -- all one last time. Summary: seems likely to be fast enough.)

    blockUntilHonestAvailabilityAssumption :: m ()
    blockUntilHonestAvailabilityAssumption :: m ()
blockUntilHonestAvailabilityAssumption =
        STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
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
$ Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ()) -> STM m Bool -> STM m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m Bool
isHaaSatisfied

    blockWhileHonestAvailabilityAssumption :: STM m ()
    blockWhileHonestAvailabilityAssumption :: STM m ()
blockWhileHonestAvailabilityAssumption =
        Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (Bool -> STM m ()) -> (Bool -> Bool) -> Bool -> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> STM m ()) -> STM m Bool -> STM m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STM m Bool
isHaaSatisfied

data TraceGsmEvent selection =
    GsmEventEnterCaughtUp !Int !selection
    -- ^ how many peers and the current selection
  |
    GsmEventLeaveCaughtUp !selection !DurationFromNow
    -- ^ the current selection and its age
  |
    GsmEventPreSyncingToSyncing
    -- ^ the Honest Availability Assumption is now satisfied
  |
    GsmEventSyncingToPreSyncing
    -- ^ the Honest Availability Assumption is no longer satisfied
  deriving (TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
(TraceGsmEvent selection -> TraceGsmEvent selection -> Bool)
-> (TraceGsmEvent selection -> TraceGsmEvent selection -> Bool)
-> Eq (TraceGsmEvent selection)
forall selection.
Eq selection =>
TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall selection.
Eq selection =>
TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
== :: TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
$c/= :: forall selection.
Eq selection =>
TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
/= :: TraceGsmEvent selection -> TraceGsmEvent selection -> Bool
Eq, Int -> TraceGsmEvent selection -> ShowS
[TraceGsmEvent selection] -> ShowS
TraceGsmEvent selection -> String
(Int -> TraceGsmEvent selection -> ShowS)
-> (TraceGsmEvent selection -> String)
-> ([TraceGsmEvent selection] -> ShowS)
-> Show (TraceGsmEvent selection)
forall selection.
Show selection =>
Int -> TraceGsmEvent selection -> ShowS
forall selection.
Show selection =>
[TraceGsmEvent selection] -> ShowS
forall selection.
Show selection =>
TraceGsmEvent selection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall selection.
Show selection =>
Int -> TraceGsmEvent selection -> ShowS
showsPrec :: Int -> TraceGsmEvent selection -> ShowS
$cshow :: forall selection.
Show selection =>
TraceGsmEvent selection -> String
show :: TraceGsmEvent selection -> String
$cshowList :: forall selection.
Show selection =>
[TraceGsmEvent selection] -> ShowS
showList :: [TraceGsmEvent selection] -> ShowS
Show)

{-------------------------------------------------------------------------------
  A helper for constructing a real 'GsmView'
-------------------------------------------------------------------------------}

newtype WrapDurationUntilTooOld m blk = DurationUntilTooOld {
    forall (m :: * -> *) blk.
WrapDurationUntilTooOld m blk
-> WithOrigin SlotNo -> m DurationFromNow
getDurationUntilTooOld :: Slot.WithOrigin Slot.SlotNo -> m DurationFromNow
  }

-- | The real system's 'durationUntilTooOld'
realDurationUntilTooOld ::
     ( HardFork.HasHardForkHistory blk
     , MonadSTM m
     )
  => L.LedgerConfig blk
  -> STM m (L.LedgerState blk L.EmptyMK)
  -> NominalDiffTime
     -- ^ If the volatile tip is older than this, then the node will exit the
     -- @CaughtUp@ state.
     --
     -- Eg 'Ouroboros.Consensus.Node.llrnMaxCaughtUpAge'
     --
     -- WARNING This function returns 'Already' if the wall clock is beyond the
     -- current ledger state's translation horizon; that may be confusing if an
     -- unexpectedly large 'NominalDiffTime' is given here (eg 1 one week).
  -> Clock.SystemTime m
  -> m (WrapDurationUntilTooOld m blk)
realDurationUntilTooOld :: forall blk (m :: * -> *).
(HasHardForkHistory blk, MonadSTM m) =>
LedgerConfig blk
-> STM m (LedgerState blk EmptyMK)
-> NominalDiffTime
-> SystemTime m
-> m (WrapDurationUntilTooOld m blk)
realDurationUntilTooOld LedgerConfig blk
lcfg STM m (LedgerState blk EmptyMK)
getLedgerState NominalDiffTime
maxCaughtUpAge SystemTime m
systemTime = do
    runner <-
        STM m (Summary (HardForkIndices blk))
-> m (RunWithCachedSummary (HardForkIndices blk) m)
forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
HardFork.runWithCachedSummary
      (STM m (Summary (HardForkIndices blk))
 -> m (RunWithCachedSummary (HardForkIndices blk) m))
-> STM m (Summary (HardForkIndices blk))
-> m (RunWithCachedSummary (HardForkIndices blk) m)
forall a b. (a -> b) -> a -> b
$ 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)
HardFork.hardForkSummary LedgerConfig blk
lcfg (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
    pure $ DurationUntilTooOld $ \WithOrigin SlotNo
woSlot -> do
        now <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
Clock.systemTimeCurrent SystemTime m
systemTime
        case woSlot of
            WithOrigin SlotNo
Slot.Origin  -> DurationFromNow -> m DurationFromNow
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DurationFromNow -> m DurationFromNow)
-> DurationFromNow -> m DurationFromNow
forall a b. (a -> b) -> a -> b
$ RelativeTime -> RelativeTime -> DurationFromNow
toDur RelativeTime
now (RelativeTime -> DurationFromNow)
-> RelativeTime -> DurationFromNow
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> RelativeTime
Clock.RelativeTime NominalDiffTime
0
            Slot.At SlotNo
slot -> do
                let qry :: Qry (RelativeTime, SlotLength)
qry = SlotNo -> Qry (RelativeTime, SlotLength)
Qry.slotToWallclock SlotNo
slot
                STM m DurationFromNow -> m DurationFromNow
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m DurationFromNow -> m DurationFromNow)
-> STM m DurationFromNow -> m DurationFromNow
forall a b. (a -> b) -> a -> b
$ RunWithCachedSummary (HardForkIndices blk) 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)
HardFork.cachedRunQuery RunWithCachedSummary (HardForkIndices blk) m
runner Qry (RelativeTime, SlotLength)
qry STM m (Either PastHorizonException (RelativeTime, SlotLength))
-> (Either PastHorizonException (RelativeTime, SlotLength)
    -> DurationFromNow)
-> STM m DurationFromNow
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                    Left Qry.PastHorizon{}  -> DurationFromNow
Already
                    Right (RelativeTime
onset, SlotLength
_slotLen) -> RelativeTime -> RelativeTime -> DurationFromNow
toDur RelativeTime
now RelativeTime
onset
  where
    toDur :: RelativeTime -> RelativeTime -> DurationFromNow
toDur
        (Clock.RelativeTime NominalDiffTime
now)
        (RelativeTime -> NominalDiffTime
Clock.getRelativeTime -> (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ NominalDiffTime
maxCaughtUpAge) -> NominalDiffTime
limit)
      = if NominalDiffTime
limit NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
now then DurationFromNow
Already else NominalDiffTime -> DurationFromNow
After (NominalDiffTime
limit NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
- NominalDiffTime
now)

{-------------------------------------------------------------------------------
  A helper for constructing a real 'GsmView'

  TODO should these operations properly be part of the ChainDB?
-------------------------------------------------------------------------------}

-- | A view on the GSM's /Caught-Up persistent marker/ file
--
-- These comments constrain the result of 'realMarkerFile'; mock views in
-- testing are free to be different.
data MarkerFileView m = MarkerFileView {
    forall (m :: * -> *). MarkerFileView m -> m Bool
hasMarkerFile    :: m Bool
  ,
    -- | Remove the marker file
    --
    -- Will throw an 'FsResourceDoesNotExist' error when it does not exist.
    forall (m :: * -> *). MarkerFileView m -> m ()
removeMarkerFile :: m ()
  ,
    -- | Create the marker file
    --
    -- Idempotent.
    forall (m :: * -> *). MarkerFileView m -> m ()
touchMarkerFile  :: m ()
  }

-- | The real system's 'MarkerFileView'
--
-- The strict 'ChainDB' argument is unused, but its existence ensures there's
-- only one process using this file system.
realMarkerFileView ::
     MonadThrow m
  => ChainDB m blk
  -> HasFS m h
     -- ^ should be independent of other filesystems, eg @gsm/@
  -> MarkerFileView m
realMarkerFileView :: forall (m :: * -> *) blk h.
MonadThrow m =>
ChainDB m blk -> HasFS m h -> MarkerFileView m
realMarkerFileView !ChainDB m blk
_cdb HasFS m h
hasFS =
    MarkerFileView {
        m Bool
hasMarkerFile :: m Bool
hasMarkerFile :: m Bool
hasMarkerFile
      ,
        removeMarkerFile :: m ()
removeMarkerFile = HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
hasFS FsPath
markerFile
      ,
        touchMarkerFile :: m ()
touchMarkerFile = do
            HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
True ([String] -> FsPath
mkFsPath [])
            alreadyExists <- m Bool
hasMarkerFile
            unless alreadyExists $
                withFile hasFS markerFile (WriteMode MustBeNew) $ \Handle h
_h ->
                    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      }
  where
    hasMarkerFile :: m Bool
hasMarkerFile = HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
markerFile

-- | The path to the GSM's /Caught-Up persistent marker/ inside its dedicated
-- 'HasFS'
--
-- If the file is present on node initialization, then the node was in the
-- @CaughtUp@ state when it shut down.
markerFile :: FsPath
markerFile :: FsPath
markerFile = [String] -> FsPath
mkFsPath [String
"CaughtUpMarker"]

{-------------------------------------------------------------------------------
  A helper for the NodeKernel
-------------------------------------------------------------------------------}

-- | Arguments the NodeKernel has to take because of the GSM
data GsmNodeKernelArgs m blk = GsmNodeKernelArgs {
    forall (m :: * -> *) blk. GsmNodeKernelArgs m blk -> StdGen
gsmAntiThunderingHerd  :: StdGen
    -- ^ See 'antiThunderingHerd'
  ,
    forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> Maybe (WrapDurationUntilTooOld m blk)
gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
    -- ^ See 'durationUntilTooOld'
  ,
    forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> MarkerFileView m
gsmMarkerFileView      :: MarkerFileView m
  ,
    forall (m :: * -> *) blk.
GsmNodeKernelArgs m blk -> NominalDiffTime
gsmMinCaughtUpDuration :: NominalDiffTime
    -- ^ See 'minCaughtUpDuration'
  }