{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Initialization of the 'BlockFetchConsensusInterface'
module Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface (
    ChainDbView (..)
  , SlotForgeTimeOracle
  , defaultChainDbView
  , initSlotForgeTimeOracle
  , mkBlockFetchConsensusInterface
  , readFetchModeDefault
  ) where

import           Control.Monad
import           Data.Map.Strict (Map)
import           Data.Time.Clock (UTCTime)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Block hiding (blockMatchesHeader)
import qualified Ouroboros.Consensus.Block as Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.Config.SupportsNode as SupportsNode
import qualified Ouroboros.Consensus.HardFork.Abstract as History
import qualified Ouroboros.Consensus.HardFork.History as History
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
                     (InvalidBlockPunishment)
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import           Ouroboros.Consensus.Util.AnchoredFragment
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Orphans ()
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (MaxSlotNo)
import           Ouroboros.Network.BlockFetch.ConsensusInterface
                     (BlockFetchConsensusInterface (..), FetchMode (..),
                     FromConsensus (..))
import           Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers,
                     requiresBootstrapPeers)
import           Ouroboros.Network.PeerSelection.LedgerPeers.Type
                     (LedgerStateJudgement)
import           Ouroboros.Network.SizeInBytes

-- | Abstract over the ChainDB
data ChainDbView m blk = ChainDbView {
     forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
getCurrentChain           :: STM m (AnchoredFragment (Header blk))
   , forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (Point blk -> Bool)
getIsFetched              :: STM m (Point blk -> Bool)
   , forall (m :: * -> *) blk. ChainDbView m blk -> STM m MaxSlotNo
getMaxSlotNo              :: STM m MaxSlotNo
   , forall (m :: * -> *) blk.
ChainDbView m blk -> InvalidBlockPunishment m -> blk -> m Bool
addBlockWaitWrittenToDisk :: InvalidBlockPunishment m -> blk -> m Bool
   }

defaultChainDbView :: IOLike m => ChainDB m blk -> ChainDbView m blk
defaultChainDbView :: forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> ChainDbView m blk
defaultChainDbView ChainDB m blk
chainDB = ChainDbView {
    getCurrentChain :: STM m (AnchoredFragment (Header blk))
getCurrentChain           = ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDB
  , getIsFetched :: STM m (Point blk -> Bool)
getIsFetched              = ChainDB m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
ChainDB.getIsFetched ChainDB m blk
chainDB
  , getMaxSlotNo :: STM m MaxSlotNo
getMaxSlotNo              = ChainDB m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDB m blk -> STM m MaxSlotNo
ChainDB.getMaxSlotNo ChainDB m blk
chainDB
  , addBlockWaitWrittenToDisk :: InvalidBlockPunishment m -> blk -> m Bool
addBlockWaitWrittenToDisk = ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk -> InvalidBlockPunishment m -> blk -> m Bool
ChainDB.addBlockWaitWrittenToDisk ChainDB m blk
chainDB
  }

-- | How to get the wall-clock time of a slot. Note that this is a very
-- non-trivial operation in the context of the HFC, cf. 'headerForgeUTCTime'.
type SlotForgeTimeOracle m blk = RealPoint blk -> STM m UTCTime

-- | Create a HFC-enabled 'SlotForgeTimeOracle'. Note that its semantics are
-- rather tricky, cf. 'headerForgeUTCTime'.
initSlotForgeTimeOracle ::
     forall m blk.
     ( IOLike m
     , BlockSupportsProtocol blk
     , History.HasHardForkHistory blk
     , SupportsNode.ConfigSupportsNode blk
     , IsLedger (LedgerState blk)
     )
  => TopLevelConfig blk
  -> ChainDB m blk
  -> m (SlotForgeTimeOracle m blk)
initSlotForgeTimeOracle :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk, HasHardForkHistory blk,
 ConfigSupportsNode blk, IsLedger (LedgerState blk)) =>
TopLevelConfig blk
-> ChainDB m blk -> m (SlotForgeTimeOracle m blk)
initSlotForgeTimeOracle TopLevelConfig blk
cfg ChainDB m blk
chainDB = do
    RunWithCachedSummary (HardForkIndices blk) m
cache <-
      STM m (Summary (HardForkIndices blk))
-> m (RunWithCachedSummary (HardForkIndices blk) m)
forall (m :: * -> *) (xs :: [*]).
MonadSTM m =>
STM m (Summary xs) -> m (RunWithCachedSummary xs m)
History.runWithCachedSummary
        (ExtLedgerState blk -> Summary (HardForkIndices blk)
toSummary (ExtLedgerState blk -> Summary (HardForkIndices blk))
-> STM m (ExtLedgerState blk)
-> STM m (Summary (HardForkIndices blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB)
    let slotForgeTime :: RealPoint blk -> STM m UTCTime
slotForgeTime RealPoint blk
rp =
              (Either PastHorizonException RelativeTime -> UTCTime)
-> STM m (Either PastHorizonException RelativeTime)
-> STM m UTCTime
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                ((PastHorizonException -> UTCTime)
-> (RelativeTime -> UTCTime)
-> Either PastHorizonException RelativeTime
-> UTCTime
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PastHorizonException -> UTCTime
forall {a} {a}. Show a => a -> a
errMsg RelativeTime -> UTCTime
toAbsolute)
            (STM m (Either PastHorizonException RelativeTime) -> STM m UTCTime)
-> STM m (Either PastHorizonException RelativeTime)
-> STM m UTCTime
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)
History.cachedRunQuery
                RunWithCachedSummary (HardForkIndices blk) m
cache
                ((RelativeTime, SlotLength) -> RelativeTime
forall a b. (a, b) -> a
fst ((RelativeTime, SlotLength) -> RelativeTime)
-> Qry (RelativeTime, SlotLength) -> Qry RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Qry (RelativeTime, SlotLength)
History.slotToWallclock (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
rp))
          where
            -- This @cachedRunQuery@ fail for the following reasons.
            --
            -- By the PRECONDITIONs documented in the 'headerForgeUTCTime', we
            -- can assume that the given header was validated by the ChainSync
            -- client. This means its slot was, at some point, within the ledger
            -- view forecast range of the ledger state of our contemporary
            -- intersection with the header itself (and that intersection
            -- extended our contemporary immutable tip). A few additional facts
            -- ensure that we will always be able to thereafter correctly
            -- convert that header's slot using our current chain's ledger
            -- state.
            --
            --   o For under-developed reasons, the ledger view forecast range
            --     is equivalent to the time forecast range, ie " Definition
            --     17.2 (Forecast range) " from The Consensus Report.
            --
            --   o Because rollback is bounded, our currently selected chain
            --     will always be an evolution (ie " switch(n, bs) ") of that
            --     intersection point. (This one is somewhat obvious in
            --     retrospect, but we're being explicit here in order to
            --     emphasize the relation to the " chain evolution " jargon.)
            --
            --   o Because " stability itself is stable ", the HFC satisfies "
            --     Property 17.3 (Time conversions stable under chain evolution)
            --     " from The Consensus Report.
            errMsg :: a -> a
errMsg a
err =
              [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
forall a b. (a -> b) -> a -> b
$
                 [Char]
"Consensus could not determine forge UTCTime!"
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> RealPoint blk -> [Char]
forall a. Show a => a -> [Char]
show RealPoint blk
rp
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> a -> [Char]
forall a. Show a => a -> [Char]
show a
err
    SlotForgeTimeOracle m blk -> m (SlotForgeTimeOracle m blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SlotForgeTimeOracle m blk
forall {blk}. StandardHash blk => RealPoint blk -> STM m UTCTime
slotForgeTime
  where
    toSummary ::
         ExtLedgerState blk
      -> History.Summary (History.HardForkIndices blk)
    toSummary :: ExtLedgerState blk -> Summary (HardForkIndices blk)
toSummary = LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
History.hardForkSummary (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg) (LedgerState blk -> Summary (HardForkIndices blk))
-> (ExtLedgerState blk -> LedgerState blk)
-> ExtLedgerState blk
-> Summary (HardForkIndices blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState

    toAbsolute :: RelativeTime -> UTCTime
    toAbsolute :: RelativeTime -> UTCTime
toAbsolute =
        SystemStart -> RelativeTime -> UTCTime
fromRelativeTime (BlockConfig blk -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
SupportsNode.getSystemStart (TopLevelConfig blk -> BlockConfig blk
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig blk
cfg))

readFetchModeDefault ::
     (MonadSTM m, HasHeader blk)
  => BlockchainTime m
  -> STM m (AnchoredFragment blk)
  -> STM m UseBootstrapPeers
  -> STM m LedgerStateJudgement
  -> STM m FetchMode
readFetchModeDefault :: forall (m :: * -> *) blk.
(MonadSTM m, HasHeader blk) =>
BlockchainTime m
-> STM m (AnchoredFragment blk)
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m FetchMode
readFetchModeDefault BlockchainTime m
btime STM m (AnchoredFragment blk)
getCurrentChain
                     STM m UseBootstrapPeers
getUseBootstrapPeers STM m LedgerStateJudgement
getLedgerStateJudgement = do
    CurrentSlot
mCurSlot <- BlockchainTime m -> STM m CurrentSlot
forall (m :: * -> *). BlockchainTime m -> STM m CurrentSlot
getCurrentSlot BlockchainTime m
btime
    Bool
usingBootstrapPeers <- UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers (UseBootstrapPeers -> LedgerStateJudgement -> Bool)
-> STM m UseBootstrapPeers -> STM m (LedgerStateJudgement -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m UseBootstrapPeers
getUseBootstrapPeers
                                                  STM m (LedgerStateJudgement -> Bool)
-> STM m LedgerStateJudgement -> STM m Bool
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m LedgerStateJudgement
getLedgerStateJudgement

    -- This logic means that when the node is using bootstrap peers and is in
    -- TooOld state it will always return BulkSync. Otherwise if the node
    -- isn't using bootstrap peers (i.e. has them disabled it will use the old
    -- logic of returning BulkSync if behind 1000 slots
    case (Bool
usingBootstrapPeers, CurrentSlot
mCurSlot) of
      (Bool
True, CurrentSlot
_)                    -> FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return FetchMode
FetchModeBulkSync
      (Bool
False, CurrentSlot
CurrentSlotUnknown)  -> FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return FetchMode
FetchModeBulkSync
      (Bool
False, CurrentSlot SlotNo
curSlot) -> do
        WithOrigin SlotNo
curChainSlot <- AnchoredFragment blk -> WithOrigin SlotNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin SlotNo
AF.headSlot (AnchoredFragment blk -> WithOrigin SlotNo)
-> STM m (AnchoredFragment blk) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (AnchoredFragment blk)
getCurrentChain
        let slotsBehind :: Word64
slotsBehind = case WithOrigin SlotNo
curChainSlot of
              -- There's nothing in the chain. If the current slot is 0, then
              -- we're 1 slot behind.
              WithOrigin SlotNo
Origin         -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
              NotOrigin SlotNo
slot -> SlotNo -> Word64
unSlotNo SlotNo
curSlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- SlotNo -> Word64
unSlotNo SlotNo
slot
            maxSlotsBehind :: Word64
maxSlotsBehind = Word64
1000
        FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FetchMode -> STM m FetchMode) -> FetchMode -> STM m FetchMode
forall a b. (a -> b) -> a -> b
$ if Word64
slotsBehind Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
maxSlotsBehind
          -- When the current chain is near to "now", use deadline mode,
          -- when it is far away, use bulk sync mode.
          then FetchMode
FetchModeDeadline
          else FetchMode
FetchModeBulkSync

mkBlockFetchConsensusInterface ::
     forall m peer blk.
     ( IOLike m
     , BlockSupportsDiffusionPipelining blk
     , BlockSupportsProtocol blk
     )
  => BlockConfig blk
  -> ChainDbView m blk
  -> STM m (Map peer (AnchoredFragment (Header blk)))
  -> (Header blk -> SizeInBytes)
  -> SlotForgeTimeOracle m blk
     -- ^ Slot forge time, see 'headerForgeUTCTime' and 'blockForgeUTCTime'.
  -> STM m FetchMode
     -- ^ See 'readFetchMode'.
  -> DiffusionPipeliningSupport
  -> BlockFetchConsensusInterface peer (Header blk) blk m
mkBlockFetchConsensusInterface :: forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk,
 BlockSupportsProtocol blk) =>
BlockConfig blk
-> ChainDbView m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> SlotForgeTimeOracle m blk
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (Header blk) blk m
mkBlockFetchConsensusInterface
  BlockConfig blk
bcfg ChainDbView m blk
chainDB STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates Header blk -> SizeInBytes
blockFetchSize SlotForgeTimeOracle m blk
slotForgeTime STM m FetchMode
readFetchMode DiffusionPipeliningSupport
pipelining =
    BlockFetchConsensusInterface {STM m (Map peer (AnchoredFragment (Header blk)))
STM m (AnchoredFragment (Header blk))
STM m MaxSlotNo
STM m FetchMode
STM m (Point blk -> Bool)
STM m (Point blk -> blk -> m ())
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
FromConsensus blk -> STM m UTCTime
FromConsensus (Header blk) -> STM m UTCTime
Header blk -> SizeInBytes
Header blk -> blk -> Bool
headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
readFetchMode :: STM m FetchMode
blockFetchSize :: Header blk -> SizeInBytes
readFetchMode :: STM m FetchMode
blockMatchesHeader :: Header blk -> blk -> Bool
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readFetchedBlocks :: STM m (Point blk -> Bool)
mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
readFetchedMaxSlotNo :: STM m MaxSlotNo
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readFetchedBlocks :: STM m (Point blk -> Bool)
mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
readFetchedMaxSlotNo :: STM m MaxSlotNo
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
compareCandidateChains :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
blockFetchSize :: Header blk -> SizeInBytes
blockMatchesHeader :: Header blk -> blk -> Bool
..}
  where
    blockMatchesHeader :: Header blk -> blk -> Bool
    blockMatchesHeader :: Header blk -> blk -> Bool
blockMatchesHeader = Header blk -> blk -> Bool
forall blk. GetHeader blk => Header blk -> blk -> Bool
Block.blockMatchesHeader

    readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
    readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCandidateChains = STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates

    readCurrentChain :: STM m (AnchoredFragment (Header blk))
    readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCurrentChain = ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (AnchoredFragment (Header blk))
getCurrentChain ChainDbView m blk
chainDB

    readFetchedBlocks :: STM m (Point blk -> Bool)
    readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchedBlocks = ChainDbView m blk -> STM m (Point blk -> Bool)
forall (m :: * -> *) blk.
ChainDbView m blk -> STM m (Point blk -> Bool)
getIsFetched ChainDbView m blk
chainDB

    -- See 'mkAddFetchedBlock_'
    mkAddFetchedBlock ::
      STM m (Point blk -> blk -> m ())
    mkAddFetchedBlock :: STM m (Point blk -> blk -> m ())
mkAddFetchedBlock = do
      BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment <- STM
  m
  (BlockConfig blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> InvalidBlockPunishment m)
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsDiffusionPipelining blk) =>
STM
  m
  (BlockConfig blk
   -> Header blk
   -> InvalidBlockPunishment m
   -> InvalidBlockPunishment m)
InvalidBlockPunishment.mkForDiffusionPipelining
      (Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ()))
-> (Point blk -> blk -> m ()) -> STM m (Point blk -> blk -> m ())
forall a b. (a -> b) -> a -> b
$ (BlockConfig blk
 -> Header blk
 -> InvalidBlockPunishment m
 -> InvalidBlockPunishment m)
-> DiffusionPipeliningSupport -> Point blk -> blk -> m ()
mkAddFetchedBlock_ BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment DiffusionPipeliningSupport
pipelining

    -- Waits until the block has been written to disk, but not until chain
    -- selection has processed the block.
    mkAddFetchedBlock_ ::
         (   BlockConfig blk
          -> Header blk
          -> InvalidBlockPunishment m
          -> InvalidBlockPunishment m
         )
      -> DiffusionPipeliningSupport
      -> Point blk
      -> blk
      -> m ()
    mkAddFetchedBlock_ :: (BlockConfig blk
 -> Header blk
 -> InvalidBlockPunishment m
 -> InvalidBlockPunishment m)
-> DiffusionPipeliningSupport -> Point blk -> blk -> m ()
mkAddFetchedBlock_ BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment DiffusionPipeliningSupport
enabledPipelining Point blk
_pt blk
blk = m Bool -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Bool -> m ()) -> m Bool -> m ()
forall a b. (a -> b) -> a -> b
$ do
       InvalidBlockPunishment m
disconnect <- m (InvalidBlockPunishment m)
forall (m :: * -> *). IOLike m => m (InvalidBlockPunishment m)
InvalidBlockPunishment.mkPunishThisThread
       -- A BlockFetch peer can either send an entire range or none of the
       -- range; anything else will incur a disconnect. And in 'FetchDeadline'
       -- mode, which is the relevant case for this kind of DoS attack (because
       -- in bulk sync, our honest peers will be streaming a very dense chain
       -- very quickly, meaning the adversary only has very small windows during
       -- which we're interested in its chains), the node only requests whole
       -- suffixes from peers: the BlockFetch decision logic does not avoid
       -- requesting a block that is already in-flight from other peers. Thus
       -- the adversary cannot send us blocks out-of-order (during
       -- 'FetchDeadline'), even if they control more than one of our peers.
       --
       -- Therefore, the following punishment logic only needs to cover the
       -- "whole chain received in-order from a single-peer" case. Which it
       -- currently does.
       --
       -- TODO maintain the context of which ChainSync candidate incurring this
       -- fetch request, and disconnect immediately if the invalid block is not
       -- the tip of that candidate. As-is, in 'FetchDeadline' they must also
       -- send the next block, but they might be able to wait long enough that
       -- it is not desirable when it arrives, and therefore not be disconnected
       -- from. So their choices are: cause a disconnect or else do nothing for
       -- long enough. Both are fine by us, from a DoS mitigation perspective.
       let punishment :: InvalidBlockPunishment m
punishment = (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall (m :: * -> *).
(Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
InvalidBlockPunishment.branch ((Invalidity -> InvalidBlockPunishment m)
 -> InvalidBlockPunishment m)
-> (Invalidity -> InvalidBlockPunishment m)
-> InvalidBlockPunishment m
forall a b. (a -> b) -> a -> b
$ \case
             -- invalid parents always cause a disconnect
             Invalidity
InvalidBlockPunishment.BlockPrefix -> InvalidBlockPunishment m
disconnect
             -- when pipelining, we forgive an invalid block itself if it's
             -- better than the previous invalid block this peer delivered
             Invalidity
InvalidBlockPunishment.BlockItself -> case DiffusionPipeliningSupport
enabledPipelining of
               DiffusionPipeliningSupport
DiffusionPipeliningOff -> InvalidBlockPunishment m
disconnect
               DiffusionPipeliningSupport
DiffusionPipeliningOn  ->
                 BlockConfig blk
-> Header blk
-> InvalidBlockPunishment m
-> InvalidBlockPunishment m
pipeliningPunishment BlockConfig blk
bcfg (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) InvalidBlockPunishment m
disconnect
       ChainDbView m blk -> InvalidBlockPunishment m -> blk -> m Bool
forall (m :: * -> *) blk.
ChainDbView m blk -> InvalidBlockPunishment m -> blk -> m Bool
addBlockWaitWrittenToDisk
         ChainDbView m blk
chainDB
         InvalidBlockPunishment m
punishment
         blk
blk

    readFetchedMaxSlotNo :: STM m MaxSlotNo
    readFetchedMaxSlotNo :: STM m MaxSlotNo
readFetchedMaxSlotNo = ChainDbView m blk -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDbView m blk -> STM m MaxSlotNo
getMaxSlotNo ChainDbView m blk
chainDB

    -- Note that @ours@ comes from the ChainDB and @cand@ from the ChainSync
    -- client.
    --
    -- Fragments are proxies for their corresponding chains; it is possible, in
    -- principle, that an empty fragment corresponds to the chain we want to
    -- adopt, and should therefore be preferred over other fragments (whose
    -- blocks we therefore do not want to download). The precondition to
    -- 'preferAnchoredCandidates' is designed precisely to rule out this
    -- possibility (for details, see the Consensus Report), but unfortunately we
    -- cannot always satisfy this precondition: although the chain sync client
    -- preserves an invariant that relates our current chain to the candidate
    -- fragment, by the time the block fetch download logic considers the
    -- fragment, our current chain might have changed.
    plausibleCandidateChain :: HasCallStack
                            => AnchoredFragment (Header blk)
                            -> AnchoredFragment (Header blk)
                            -> Bool
    plausibleCandidateChain :: HasCallStack =>
AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Bool
plausibleCandidateChain AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand
      -- 1. The ChainDB maintains the invariant that the anchor of our fragment
      --    corresponds to the immutable tip.
      --
      -- 2. The ChainSync client locally maintains the invariant that our
      --    fragment and the candidate fragment have the same anchor point. This
      --    establishes the precondition required by @preferAnchoredCandidate@.
      --
      -- 3. However, by the time that the BlockFetch logic processes a fragment
      --    presented to it by the ChainSync client, our current fragment might
      --    have changed, and they might no longer be anchored at the same
      --    point. This means that we are no longer guaranteed that the
      --    precondition holds.
      --
      -- 4. Our chain's anchor can only move forward. We can detect this by
      --    looking at the block/slot numbers of the anchors: When the anchor
      --    advances, either the block number increases (usual case), or the
      --    block number stays the same, but the slot number increases (EBB
      --    case).
      --
      | AnchoredFragment (Header blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (Header blk)
cand (WithOrigin BlockNo, WithOrigin SlotNo)
-> (WithOrigin BlockNo, WithOrigin SlotNo) -> Bool
forall a. Ord a => a -> a -> Bool
< AnchoredFragment (Header blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (Header blk)
ours  -- (4)
      = case (AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
ours, AnchoredFragment (Header blk) -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment (Header blk)
cand) of
          -- Both are non-empty, the precondition trivially holds.
          (Bool
False, Bool
False) -> BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
bcfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand
          -- The candidate is shorter than our chain and, worse, we'd have to
          -- roll back past our immutable tip (the anchor of @cand@).
          (Bool
_,     Bool
True)  -> Bool
False
          -- As argued above we can only reach this case when our chain's anchor
          -- has changed (4).
          --
          -- It is impossible for our chain to change /and/ still be empty: the
          -- anchor of our chain only changes when a new block becomes
          -- immutable. For a new block to become immutable, we must have
          -- extended our chain with at least @k + 1@ blocks. Which means our
          -- fragment can't be empty.
          (Bool
True,  Bool
_)     -> [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

      | Bool
otherwise
      = BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
preferAnchoredCandidate BlockConfig blk
bcfg AnchoredFragment (Header blk)
ours AnchoredFragment (Header blk)
cand
      where
        anchorBlockNoAndSlot ::
             AnchoredFragment (Header blk)
          -> (WithOrigin BlockNo, WithOrigin SlotNo)
        anchorBlockNoAndSlot :: AnchoredFragment (Header blk)
-> (WithOrigin BlockNo, WithOrigin SlotNo)
anchorBlockNoAndSlot AnchoredFragment (Header blk)
frag =
            (Anchor (Header blk) -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor (Header blk)
a, Anchor (Header blk) -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo Anchor (Header blk)
a)
          where
            a :: Anchor (Header blk)
a = AnchoredFragment (Header blk) -> Anchor (Header blk)
forall v a b. AnchoredSeq v a b -> a
AF.anchor AnchoredFragment (Header blk)
frag

    compareCandidateChains :: AnchoredFragment (Header blk)
                           -> AnchoredFragment (Header blk)
                           -> Ordering
    compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk) -> Ordering
compareCandidateChains = BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
forall blk.
(BlockSupportsProtocol blk, HasCallStack) =>
BlockConfig blk
-> AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareAnchoredFragments BlockConfig blk
bcfg

    headerForgeUTCTime :: FromConsensus (Header blk) -> STM m UTCTime
headerForgeUTCTime = SlotForgeTimeOracle m blk
slotForgeTime SlotForgeTimeOracle m blk
-> (FromConsensus (Header blk) -> RealPoint blk)
-> FromConsensus (Header blk)
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header blk -> RealPoint blk
forall blk.
(HasHeader (Header blk), HasHeader blk) =>
Header blk -> RealPoint blk
headerRealPoint (Header blk -> RealPoint blk)
-> (FromConsensus (Header blk) -> Header blk)
-> FromConsensus (Header blk)
-> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromConsensus (Header blk) -> Header blk
forall a. FromConsensus a -> a
unFromConsensus
    blockForgeUTCTime :: FromConsensus blk -> STM m UTCTime
blockForgeUTCTime  = SlotForgeTimeOracle m blk
slotForgeTime SlotForgeTimeOracle m blk
-> (FromConsensus blk -> RealPoint blk)
-> FromConsensus blk
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint  (blk -> RealPoint blk)
-> (FromConsensus blk -> blk) -> FromConsensus blk -> RealPoint blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FromConsensus blk -> blk
forall a. FromConsensus a -> a
unFromConsensus