content: {-# 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
    = -- | INVARIANT positive
      After !NominalDiffTime
    | -- | This value represents all non-positive durations, ie events from the
      -- past
      Already
    deriving (Eq, Show)
  
  data CandidateVersusSelection
    = -- | 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.
      CandidateDoesNotIntersect
    | -- | Whether the candidate is better than the selection
      WhetherCandidateIsBetter !Bool
    deriving (Eq, Show)
  
  data GsmView m upstreamPeer selection chainSyncState = GsmView
    { 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.
    , candidateOverSelection ::
        selection ->
        chainSyncState ->
        CandidateVersusSelection
    , peerIsIdle :: chainSyncState -> Bool
    , 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.
    , equivalent :: selection -> selection -> Bool
    -- ^ Whether the two selections are equivalent for the purpose of the
    -- Genesis State Machine
    , getChainSyncStates ::
        STM m (Map.Map upstreamPeer (StrictTVar m chainSyncState))
    -- ^ The current ChainSync state with the latest candidates from the
    -- upstream peers
    , getCurrentSelection :: STM m selection
    -- ^ The node's current selection
    , 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'.
    , setCaughtUpPersistentMark :: Bool -> m ()
    -- ^ EG touch/delete the marker file on disk
    , writeGsmState :: GsmState -> m ()
    -- ^ EG update the TVar that the Diffusion Layer monitors, or en-/disable
    -- certain components of Genesis
    , 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
    { 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)
    , 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) ->
    -- | 'Nothing' if @blk@ has no age limit
    Maybe (WrapDurationUntilTooOld m blk) ->
    MarkerFileView m ->
    m GsmState
  initializationGsmState
    getCurrentLedger
    mbDurationUntilTooOld
    markerFileView =
      do
        wasCaughtUp <- hasMarkerFile markerFileView
        if not wasCaughtUp
          then pure PreSyncing
          else do
            case mbDurationUntilTooOld of
              Nothing -> return CaughtUp
              Just wd -> do
                sno <- L.getTipSlot <$> getCurrentLedger
                getDurationUntilTooOld wd sno >>= \case
                  After{} -> return CaughtUp
                  Already -> do
                    removeMarkerFile markerFileView
                    return PreSyncing
  
  -- | For 'LedgerStateJudgement' as used in the Diffusion layer, there is no
  -- difference between 'PreSyncing' and 'Syncing'.
  gsmStateToLedgerJudgement :: GsmState -> LedgerStateJudgement
  gsmStateToLedgerJudgement = \case
    PreSyncing -> TooOld
    Syncing -> TooOld
    CaughtUp -> 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 tracerArgs gsmView =
    GsmEntryPoints
      { enterCaughtUp
      , enterPreSyncing
      }
   where
    (cnvSelection, tracer) = tracerArgs
  
    GsmView
      { antiThunderingHerd
      , candidateOverSelection
      , peerIsIdle
      , durationUntilTooOld
      , equivalent
      , getChainSyncStates
      , getCurrentSelection
      , minCaughtUpDuration
      , setCaughtUpPersistentMark
      , writeGsmState
      , isHaaSatisfied
      } = gsmView
  
    enterCaughtUp :: forall neverTerminates. m neverTerminates
    enterCaughtUp = do
      traceWith tracer GsmEventInitializedInCaughtUp
      enterCaughtUp' antiThunderingHerd
  
    enterPreSyncing :: forall neverTerminates. m neverTerminates
    enterPreSyncing = do
      traceWith tracer GsmEventInitializedInPreSyncing
      enterPreSyncing' antiThunderingHerd
  
    enterCaughtUp' :: forall neverTerminates. Maybe StdGen -> m neverTerminates
    enterCaughtUp' g = do
      (g', ev) <- blockWhileCaughtUp g
  
      setCaughtUpPersistentMark False
      writeGsmState PreSyncing
      traceWith tracer ev
  
      enterPreSyncing' g'
  
    enterPreSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
    enterPreSyncing' g = do
      blockUntilHonestAvailabilityAssumption
  
      writeGsmState Syncing
      traceWith tracer GsmEventPreSyncingToSyncing
  
      enterSyncing' g
  
    enterSyncing' :: Maybe StdGen -> forall neverTerminates. m neverTerminates
    enterSyncing' g = do
      -- Wait until either the Honest Availability Assumption is no longer
      -- satisfied, or we are caught up.
      mev <-
        atomically $
          (Nothing <$ blockWhileHonestAvailabilityAssumption)
            `orElse` (Just <$> blockUntilCaughtUp)
  
      case mev of
        Nothing -> do
          writeGsmState PreSyncing
          traceWith tracer GsmEventSyncingToPreSyncing
  
          enterPreSyncing' g
        Just ev -> do
          writeGsmState CaughtUp
          setCaughtUpPersistentMark True
          traceWith tracer ev
  
          -- When transitioning from Syncing to CaughtUp, the node will remain
          -- in CaughtUp for at least 'minCaughtUpDuration', regardless of the
          -- selection's age.
          SI.threadDelay $ realToFrac minCaughtUpDuration
  
          enterCaughtUp' g
  
    blockWhileCaughtUp ::
      Maybe StdGen ->
      m (Maybe StdGen, TraceGsmEvent tracedSelection)
    blockWhileCaughtUp 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 (bonus, g') = case g of
            Nothing -> (0, Nothing) -- it's disabled in some tests
            Just x ->
              let (seconds, !g'') =
                    uniformR (0, 300 :: Int) x
               in (fromIntegral seconds, Just g'')
  
      ev <- atomically getCurrentSelection >>= blockWhileCaughtUpHelper bonus
  
      pure (g', ev)
  
    blockWhileCaughtUpHelper ::
      SI.DiffTime ->
      selection ->
      m (TraceGsmEvent tracedSelection)
    blockWhileCaughtUpHelper bonus selection = do
      let tracedSelection = cnvSelection selection
  
          computeDuration :: m (Maybe DurationFromNow)
          computeDuration = mapM ($ selection) durationUntilTooOld
      computeDuration >>= \case
        Nothing -> forever $ threadDelay maxBound
        Just Already -> do
          -- it's already too old
          pure $ GsmEventLeaveCaughtUp tracedSelection Already
        Just (After dur) -> do
          varTimeoutExpired <- SI.registerDelay (realToFrac dur + 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 = GsmEventLeaveCaughtUp tracedSelection (After 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 = do
      -- STAGE 1: all ChainSync clients report no subsequent headers
      varsState <- 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 =
            WhetherCandidateIsBetter False
              == candidateOverSelection selection 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 =
      atomically $ check =<< isHaaSatisfied
  
    blockWhileHonestAvailabilityAssumption :: STM m ()
    blockWhileHonestAvailabilityAssumption =
      check . not =<< isHaaSatisfied
  
  data TraceGsmEvent selection
    = -- | The GSM was initialized in the 'CaughtUp' state.
      GsmEventInitializedInCaughtUp
    | -- | The GSM was initialized in the 'PreSyncing' state.
      GsmEventInitializedInPreSyncing
    | -- | The GSM transitioned from 'Syncing' to 'CaughtUp'.
      --
      -- Includes the number of peers and the current selection.
      GsmEventEnterCaughtUp !Int !selection
    | -- | The GSM transitioned from 'CaughtUp' to 'PreSyncing'.
      --
      -- Includes the current selection and its age.
      GsmEventLeaveCaughtUp !selection !DurationFromNow
    | -- | The Honest Availability Assumption is now satisfied.
      GsmEventPreSyncingToSyncing
    | -- | The Honest Availability Assumption is no longer satisfied.
      GsmEventSyncingToPreSyncing
    deriving (Eq, Show)
  
  {-------------------------------------------------------------------------------
    A helper for constructing a real 'GsmView'
  -------------------------------------------------------------------------------}
  
  newtype WrapDurationUntilTooOld m blk = DurationUntilTooOld
    { 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) ->
    -- | 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).
    NominalDiffTime ->
    Clock.SystemTime m ->
    m (WrapDurationUntilTooOld m blk)
  realDurationUntilTooOld lcfg getLedgerState maxCaughtUpAge systemTime = do
    runner <-
      HardFork.runWithCachedSummary $
        HardFork.hardForkSummary lcfg <$> getLedgerState
    pure $ DurationUntilTooOld $ \woSlot -> do
      now <- Clock.systemTimeCurrent systemTime
      case woSlot of
        Slot.Origin -> pure $ toDur now $ Clock.RelativeTime 0
        Slot.At slot -> do
          let qry = Qry.slotToWallclock slot
          atomically $
            HardFork.cachedRunQuery runner qry <&> \case
              Left Qry.PastHorizon{} -> Already
              Right (onset, _slotLen) -> toDur now onset
   where
    toDur
      (Clock.RelativeTime now)
      (Clock.getRelativeTime -> (+ maxCaughtUpAge) -> limit) =
        if limit <= now then Already else After (limit - 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
    { hasMarkerFile :: m Bool
    , removeMarkerFile :: m ()
    -- ^ Remove the marker file
    --
    -- Will throw an 'FsResourceDoesNotExist' error when it does not exist.
    , touchMarkerFile :: m ()
    -- ^ Create the marker file
    --
    -- Idempotent.
    }
  
  -- | 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 ->
    -- | should be independent of other filesystems, eg @gsm/@
    HasFS m h ->
    MarkerFileView m
  realMarkerFileView !_cdb hasFS =
    MarkerFileView
      { hasMarkerFile
      , removeMarkerFile = removeFile hasFS markerFile
      , touchMarkerFile = do
          createDirectoryIfMissing hasFS True (mkFsPath [])
          alreadyExists <- hasMarkerFile
          unless alreadyExists $
            withFile hasFS markerFile (WriteMode MustBeNew) $ \_h ->
              return ()
      }
   where
    hasMarkerFile = doesFileExist hasFS 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 = mkFsPath ["CaughtUpMarker"]
  
  {-------------------------------------------------------------------------------
    A helper for the NodeKernel
  -------------------------------------------------------------------------------}
  
  -- | Arguments the NodeKernel has to take because of the GSM
  data GsmNodeKernelArgs m blk = GsmNodeKernelArgs
    { gsmAntiThunderingHerd :: StdGen
    -- ^ See 'antiThunderingHerd'
    , gsmDurationUntilTooOld :: Maybe (WrapDurationUntilTooOld m blk)
    -- ^ See 'durationUntilTooOld'
    , gsmMarkerFileView :: MarkerFileView m
    , gsmMinCaughtUpDuration :: NominalDiffTime
    -- ^ See 'minCaughtUpDuration'
    }
  