{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor  #-}
{-# LANGUAGE DeriveGeneric  #-}
{-# LANGUAGE LambdaCase     #-}
{-# LANGUAGE RankNTypes     #-}

module Ouroboros.Network.BlockFetch.ConsensusInterface
  ( PraosFetchMode (..)
  , FetchMode (..)
  , BlockFetchConsensusInterface (..)
  , FromConsensus (..)
  , ChainSelStarvation (..)
  , mkReadFetchMode
  ) where

import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime (UTCTime)
import Control.Monad.Class.MonadTime.SI (Time)
import Data.Functor ((<&>))

import Data.Map.Strict (Map)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import NoThunks.Class (NoThunks)

import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import Ouroboros.Network.Block
import Ouroboros.Network.ConsensusMode (ConsensusMode (..))
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
           (LedgerStateJudgement (..))
import Ouroboros.Network.SizeInBytes (SizeInBytes)

data PraosFetchMode =
       -- | Use this mode when we are catching up on the chain but are stil
       -- well behind. In this mode the fetch logic will optimise for
       -- throughput rather than latency.
       --
       FetchModeBulkSync

       -- | Use this mode for block-producing nodes that have a known deadline
       -- to produce a block and need to get the best chain before that. In
       -- this mode the fetch logic will optimise for picking the best chain
       -- within the given deadline.
     | FetchModeDeadline

       -- TODO: add an additional mode for in-between: when we are a core node
       -- following the chain but do not have an imminent deadline, or are a
       -- relay forwarding chains within the network.
       --
       -- This is a mixed mode because we have to combine the distribution of
       -- time to next block under praos, with the distribution of latency of
       -- our peers, and also the consensus preference.

  deriving (PraosFetchMode -> PraosFetchMode -> Bool
(PraosFetchMode -> PraosFetchMode -> Bool)
-> (PraosFetchMode -> PraosFetchMode -> Bool) -> Eq PraosFetchMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PraosFetchMode -> PraosFetchMode -> Bool
== :: PraosFetchMode -> PraosFetchMode -> Bool
$c/= :: PraosFetchMode -> PraosFetchMode -> Bool
/= :: PraosFetchMode -> PraosFetchMode -> Bool
Eq, Int -> PraosFetchMode -> ShowS
[PraosFetchMode] -> ShowS
PraosFetchMode -> String
(Int -> PraosFetchMode -> ShowS)
-> (PraosFetchMode -> String)
-> ([PraosFetchMode] -> ShowS)
-> Show PraosFetchMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PraosFetchMode -> ShowS
showsPrec :: Int -> PraosFetchMode -> ShowS
$cshow :: PraosFetchMode -> String
show :: PraosFetchMode -> String
$cshowList :: [PraosFetchMode] -> ShowS
showList :: [PraosFetchMode] -> ShowS
Show)

-- | The fetch mode that the block fetch logic should use.
data FetchMode = FetchModeGenesis | PraosFetchMode PraosFetchMode
  deriving (FetchMode -> FetchMode -> Bool
(FetchMode -> FetchMode -> Bool)
-> (FetchMode -> FetchMode -> Bool) -> Eq FetchMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FetchMode -> FetchMode -> Bool
== :: FetchMode -> FetchMode -> Bool
$c/= :: FetchMode -> FetchMode -> Bool
/= :: FetchMode -> FetchMode -> Bool
Eq, Int -> FetchMode -> ShowS
[FetchMode] -> ShowS
FetchMode -> String
(Int -> FetchMode -> ShowS)
-> (FetchMode -> String)
-> ([FetchMode] -> ShowS)
-> Show FetchMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FetchMode -> ShowS
showsPrec :: Int -> FetchMode -> ShowS
$cshow :: FetchMode -> String
show :: FetchMode -> String
$cshowList :: [FetchMode] -> ShowS
showList :: [FetchMode] -> ShowS
Show)

-- | Construct 'readFetchMode' for 'BlockFetchConsensusInterface' by branching
-- on the 'ConsensusMode'.
mkReadFetchMode
  :: Functor m
  => ConsensusMode
  -> m LedgerStateJudgement
     -- ^ Used for 'GenesisMode'.
  -> m PraosFetchMode
     -- ^ Used for 'PraosMode' for backwards compatibility.
  -> m FetchMode
mkReadFetchMode :: forall (m :: * -> *).
Functor m =>
ConsensusMode
-> m LedgerStateJudgement -> m PraosFetchMode -> m FetchMode
mkReadFetchMode ConsensusMode
consensusMode m LedgerStateJudgement
getLedgerStateJudgement m PraosFetchMode
getFetchMode =
    case ConsensusMode
consensusMode of
      ConsensusMode
GenesisMode -> m LedgerStateJudgement
getLedgerStateJudgement m LedgerStateJudgement
-> (LedgerStateJudgement -> FetchMode) -> m FetchMode
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        LedgerStateJudgement
YoungEnough -> PraosFetchMode -> FetchMode
PraosFetchMode PraosFetchMode
FetchModeDeadline
        LedgerStateJudgement
TooOld      -> FetchMode
FetchModeGenesis
      ConsensusMode
PraosMode   -> PraosFetchMode -> FetchMode
PraosFetchMode (PraosFetchMode -> FetchMode) -> m PraosFetchMode -> m FetchMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PraosFetchMode
getFetchMode

-- | The consensus layer functionality that the block fetch logic requires.
--
-- These are provided as input to the block fetch by the consensus layer.
--
data BlockFetchConsensusInterface peer header block m =
     BlockFetchConsensusInterface {

       -- | Read the K-suffixes of the candidate chains.
       --
       -- Assumptions:
       -- * Their headers must be already validated.
       -- * They may contain /fewer/ than @K@ blocks.
       -- * Their anchor does not have to intersect with the current chain.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Map peer (AnchoredFragment header))
readCandidateChains    :: STM m (Map peer (AnchoredFragment header)),

       -- | Read the K-suffix of the current chain.
       --
       -- This must contain info on the last @K@ blocks (unless we're near
       -- the chain genesis of course).
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (AnchoredFragment header)
readCurrentChain       :: STM m (AnchoredFragment header),

       -- | Read the current fetch mode that the block fetch logic should use.
       --
       -- The fetch mode is a dynamic part of the block fetch policy. In
       -- 'FetchModeBulkSync' it follows a policy that optimises for expected
       -- bandwidth over latency to fetch any particular block, whereas in
       -- 'FetchModeDeadline' it follows a policy optimises for the latency
       -- to fetch blocks, at the expense of wasting bandwidth.
       --
       -- 'FetchModeGenesis' should be used when the genesis node is syncing to
       -- ensure it isn't leashed.
       --
       -- This mode should be set so that when the node's current chain is near
       -- to \"now\" it uses the deadline mode, and when it is far away it uses
       -- the bulk sync mode.
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readFetchMode          :: STM m FetchMode,

       -- | Recent, only within last K
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> Bool)
readFetchedBlocks      :: STM m (Point block -> Bool),

       -- | This method allocates an @addFetchedBlock@ function per client.
       -- That function and 'readFetchedBlocks' are required to be linked. Upon
       -- successful completion of @addFetchedBlock@ it must be the case that
       -- 'readFetchedBlocks' reports the block.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> block -> m ())
mkAddFetchedBlock      :: STM m (Point block -> block -> m ()),

       -- | The highest stored/downloaded slot number.
       --
       -- This is used to optimise the filtering of fragments in the block
       -- fetch logic: when removing already downloaded blocks from a
       -- fragment, the filtering (with a linear cost) is stopped as soon as a
       -- block has a slot number higher than this slot number, as it cannot
       -- have been downloaded anyway.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m MaxSlotNo
readFetchedMaxSlotNo    :: STM m MaxSlotNo,

       -- | Given the current chain, is the given chain plausible as a
       -- candidate chain. Classically for Ouroboros this would simply
       -- check if the candidate is strictly longer, but for Ouroboros
       -- with operational key certificates there are also cases where
       -- we would consider a chain of equal length to the current chain.
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
   AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack
                               => AnchoredFragment header
                               -> AnchoredFragment header -> Bool,

       -- | Compare two candidate chains and return a preference ordering.
       -- This is used as part of selecting which chains to prioritise for
       -- downloading block bodies.
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
   AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains  :: HasCallStack
                               => AnchoredFragment header
                               -> AnchoredFragment header
                               -> Ordering,

       -- | Much of the logic for deciding which blocks to download from which
       -- peer depends on making estimates based on recent performance metrics.
       -- These estimates of course depend on the amount of data we will be
       -- downloading.
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> SizeInBytes
blockFetchSize          :: header -> SizeInBytes,

       -- | Given a block header, validate the supposed corresponding block
       -- body.
       --
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> block -> Bool
blockMatchesHeader      :: header -> block -> Bool,

       -- | Calculate when a header's block was forged.
       --
       -- PRECONDITION: This function will succeed and give a _correct_ result
       -- when applied to headers obtained via this interface (ie via
       -- Consensus, ie via 'readCurrentChain' or 'readCandidateChains').
       --
       -- WARNING: This function may fail or, worse, __give an incorrect result
       -- (!!)__ if applied to headers obtained from sources outside of this
       -- interface. The 'FromConsensus' newtype wrapper is intended to make it
       -- difficult to make that mistake, so please pay that syntactic price
       -- and consider its meaning at each call to this function. Relatedly,
       -- preserve that argument wrapper as much as possible when deriving
       -- ancillary functions\/interfaces from this function.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> FromConsensus header -> STM m UTCTime
headerForgeUTCTime :: FromConsensus header -> STM m UTCTime,

       -- | Information on the ChainSel starvation status; whether it is ongoing
       -- or has ended recently. Needed by the bulk sync decision logic.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m ChainSelStarvation
readChainSelStarvation :: STM m ChainSelStarvation,

       -- | Action to inform CSJ (ChainSync Jumping) that the given peer has not
       -- been performing adequately with respect to BlockFetch, and that it
       -- should be demoted from the dynamo role. Can be set to @const (pure
       -- ())@ in all other scenarios.
       forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> peer -> m ()
demoteChainSyncJumpingDynamo :: peer -> m ()
     }


-- | Whether ChainSel is starved or has been recently.
--
-- The bulk sync fetch decision logic needs to decide whether the current
-- focused peer has starved ChainSel recently. This datatype is used to
-- represent this piece of information.
data ChainSelStarvation
  = ChainSelStarvationOngoing
  | ChainSelStarvationEndedAt Time
  deriving (ChainSelStarvation -> ChainSelStarvation -> Bool
(ChainSelStarvation -> ChainSelStarvation -> Bool)
-> (ChainSelStarvation -> ChainSelStarvation -> Bool)
-> Eq ChainSelStarvation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainSelStarvation -> ChainSelStarvation -> Bool
== :: ChainSelStarvation -> ChainSelStarvation -> Bool
$c/= :: ChainSelStarvation -> ChainSelStarvation -> Bool
/= :: ChainSelStarvation -> ChainSelStarvation -> Bool
Eq, Int -> ChainSelStarvation -> ShowS
[ChainSelStarvation] -> ShowS
ChainSelStarvation -> String
(Int -> ChainSelStarvation -> ShowS)
-> (ChainSelStarvation -> String)
-> ([ChainSelStarvation] -> ShowS)
-> Show ChainSelStarvation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainSelStarvation -> ShowS
showsPrec :: Int -> ChainSelStarvation -> ShowS
$cshow :: ChainSelStarvation -> String
show :: ChainSelStarvation -> String
$cshowList :: [ChainSelStarvation] -> ShowS
showList :: [ChainSelStarvation] -> ShowS
Show, Context -> ChainSelStarvation -> IO (Maybe ThunkInfo)
Proxy ChainSelStarvation -> String
(Context -> ChainSelStarvation -> IO (Maybe ThunkInfo))
-> (Context -> ChainSelStarvation -> IO (Maybe ThunkInfo))
-> (Proxy ChainSelStarvation -> String)
-> NoThunks ChainSelStarvation
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ChainSelStarvation -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainSelStarvation -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainSelStarvation -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainSelStarvation -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ChainSelStarvation -> String
showTypeOf :: Proxy ChainSelStarvation -> String
NoThunks, (forall x. ChainSelStarvation -> Rep ChainSelStarvation x)
-> (forall x. Rep ChainSelStarvation x -> ChainSelStarvation)
-> Generic ChainSelStarvation
forall x. Rep ChainSelStarvation x -> ChainSelStarvation
forall x. ChainSelStarvation -> Rep ChainSelStarvation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainSelStarvation -> Rep ChainSelStarvation x
from :: forall x. ChainSelStarvation -> Rep ChainSelStarvation x
$cto :: forall x. Rep ChainSelStarvation x -> ChainSelStarvation
to :: forall x. Rep ChainSelStarvation x -> ChainSelStarvation
Generic)

{-------------------------------------------------------------------------------
  Syntactic indicator of key precondition about Consensus time conversions
-------------------------------------------------------------------------------}

-- | A new type used to emphasize the precondition of
-- 'Ouroboros.Network.BlockFetch.ConsensusInterface.headerForgeUTCTime' and
-- 'Ouroboros.Network.BlockFetch.ConsensusInterface.blockForgeUTCTime' at each
-- call site.
--
-- At time of writing, the @a@ is either a header or a block. The headers are
-- literally from Consensus (ie provided by ChainSync). Blocks, on the other
-- hand, are indirectly from Consensus: they were fetched only because we
-- favored the corresponding header that Consensus provided.
newtype FromConsensus a = FromConsensus {forall a. FromConsensus a -> a
unFromConsensus :: a}
  deriving ((forall a b. (a -> b) -> FromConsensus a -> FromConsensus b)
-> (forall a b. a -> FromConsensus b -> FromConsensus a)
-> Functor FromConsensus
forall a b. a -> FromConsensus b -> FromConsensus a
forall a b. (a -> b) -> FromConsensus a -> FromConsensus b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FromConsensus a -> FromConsensus b
fmap :: forall a b. (a -> b) -> FromConsensus a -> FromConsensus b
$c<$ :: forall a b. a -> FromConsensus b -> FromConsensus a
<$ :: forall a b. a -> FromConsensus b -> FromConsensus a
Functor)

instance Applicative FromConsensus where
  pure :: forall a. a -> FromConsensus a
pure = a -> FromConsensus a
forall a. a -> FromConsensus a
FromConsensus
  FromConsensus a -> b
f <*> :: forall a b.
FromConsensus (a -> b) -> FromConsensus a -> FromConsensus b
<*> FromConsensus a
a = b -> FromConsensus b
forall a. a -> FromConsensus a
FromConsensus (a -> b
f a
a)