{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

{-| Let's start with the big picture...

@
Key:  ┏━━━━━━━━━━━━┓  ╔═════════════╗  ┏━━━━━━━━━━━━━━┓   ╔════════════╗
      ┃ STM-based  ┃  ║active thread║  ┃state instance┃┓  ║ one thread ║╗
      ┃shared state┃  ║             ║  ┃   per peer   ┃┃  ║  per peer  ║║
      ┗━━━━━━━━━━━━┛  ╚═════════════╝  ┗━━━━━━━━━━━━━━┛┃  ╚════════════╝║
                                        ┗━━━━━━━━━━━━━━┛   ╚════════════╝
@

@
  ╔═════════════╗     ┏━━━━━━━━━━━━━┓
  ║ Chain sync  ║╗    ┃   Ledger    ┃
  ║  protocol   ║║◀───┨   state     ┃◀───────────╮
  ║(client side)║║    ┃             ┃            │
  ╚══════╤══════╝║    ┗━━━━━━━━━━━━━┛            │
   ╚═════╪═══════╝                               │
         ▼                                       │
  ┏━━━━━━━━━━━━━┓     ┏━━━━━━━━━━━━━┓     ╔══════╧══════╗
  ┃  Candidate  ┃     ┃   Set of    ┃     ║  Chain and  ║
  ┃  chains     ┃     ┃  downloaded ┠────▶║   ledger    ║
  ┃  (headers)  ┃     ┃   blocks    ┃     ║  validation ║
  ┗━━━━━┯━━━━━━━┛     ┗━━━━━┯━━━━━━━┛     ╚══════╤══════╝
        │                   │ ▲                  │
        │ ╭─────────────────╯ │                  │
░░░░░░░░▼░▼░░░░░░░░           │                  ▼
░░╔═════════════╗░░           │           ┏━━━━━━━━━━━━━┓     ╔═════════════╗
░░║    Block    ║░░           │           ┃   Current   ┃     ║ Block fetch ║╗
░░╢    fetch    ║◀────────────┼───────────┨    chain    ┠────▶║ protocol    ║║
░░║    logic    ║░░           │           ┃  (blocks)   ┃     ║(server side)║║
░░╚═════════════╝░░           │           ┠─────────────┨     ╚═════════════╝║
░░░░░░░░░▲░░░░░░░░░           │           ┃  Tentative  ┃      ╚═════════════╝
░░░░░░░░░▼░░░░░░░░░░░░░░░░░░░░│░░░░░░░░   ┃    chain    ┠──╮
░░┏━━━━━━━━━━━━━┓░░░░░╔═══════╧═════╗░░   ┃  (headers)  ┃  │  ╔═════════════╗
░░┃ Block fetch ┃┓░░░░║ block fetch ║╗░   ┗━━━━━━━━━━━━━┛  │  ║ Chain sync  ║╗
░░┃  state and  ┃┃◀──▶║  protocol   ║║░                    ╰─▶║ protocol    ║║
░░┃  requests   ┃┃░░░░║(client side)║║░                       ║(server side)║║
░░┗━━━━━━━━━━━━━┛┃░░░░╚═════════════╝║░                       ╚═════════════╝║
░░░┗━━━━━━━━━━━━━┛░░░░░╚═════════════╝░                        ╚═════════════╝
░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░
@
Notes:

 * Thread communication is via STM based state.
 * Outbound: threads update STM state.
 * Inbound: threads wait on STM state changing (using retry).
 * These are no queues: there is only the current state, not all change events.

We consider the block fetch logic and the policy for the block fetch protocol
client together as one unit of functionality. This is the shaded area in the
diagram.

Looking at the diagram we see that these two threads interact with each other
and other threads via the following shared state

+-----------------------------+----------------+--------------------+
|  State                      |  Interactions  | Internal\/External |
+=============================+================+====================+
|  Candidate chains (headers) |  Read          |  External          |
+-----------------------------+----------------+--------------------+
|  Current chain (blocks)     |  Read          |  External          |
+-----------------------------+----------------+--------------------+
|  Set of downloaded blocks   |  Read & Write  |  External          |
+-----------------------------+----------------+--------------------+
|  Block fetch requests       |  Read & Write  |  Internal          |
+-----------------------------+----------------+--------------------+

The block fetch requests state is private between the block fetch logic
and the block fetch protocol client, so it is implemented here.

The other state is managed by the consensus layer and is considered external
here. So here we define interfaces for interacting with the external state.
These have to be provided when instantiating the block fetch logic.

-}
module Ouroboros.Network.BlockFetch
  ( blockFetchLogic
  , BlockFetchConfiguration (..)
  , BlockFetchConsensusInterface (..)
    -- ** Tracer types
  , FetchDecision
  , TraceFetchClientState (..)
  , TraceLabelPeer (..)
    -- * The 'FetchClientRegistry'
  , FetchClientRegistry
  , newFetchClientRegistry
  , bracketFetchClient
  , bracketSyncWithFetchClient
  , bracketKeepAliveClient
    -- * Re-export types used by 'BlockFetchConsensusInterface'
  , FetchMode (..)
  , FromConsensus (..)
  , SizeInBytes
  ) where

import Data.Hashable (Hashable)
import Data.Void

import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer)

import Ouroboros.Network.Block
import Ouroboros.Network.SizeInBytes (SizeInBytes)

import Ouroboros.Network.BlockFetch.ClientRegistry (FetchClientPolicy (..),
           FetchClientRegistry, bracketFetchClient, bracketKeepAliveClient,
           bracketSyncWithFetchClient, newFetchClientRegistry,
           readFetchClientsStateVars, readFetchClientsStatus, readPeerGSVs,
           setFetchClientContext)
import Ouroboros.Network.BlockFetch.ConsensusInterface
           (BlockFetchConsensusInterface (..), FromConsensus (..))
import Ouroboros.Network.BlockFetch.State



-- | Configuration for FetchDecisionPolicy.
-- Should be determined by external local node config.
data BlockFetchConfiguration =
     BlockFetchConfiguration {
         -- | Maximum concurrent downloads during bulk syncing.
         BlockFetchConfiguration -> Word
bfcMaxConcurrencyBulkSync :: !Word,

         -- | Maximum concurrent downloads during deadline syncing.
         BlockFetchConfiguration -> Word
bfcMaxConcurrencyDeadline :: !Word,

         -- | Maximum requests in flight per each peer.
         BlockFetchConfiguration -> Word
bfcMaxRequestsInflight    :: !Word,

         -- | Desired interval between calls to fetchLogicIteration
         BlockFetchConfiguration -> DiffTime
bfcDecisionLoopInterval   :: !DiffTime,

         -- | Salt used when comparing peers
         BlockFetchConfiguration -> Int
bfcSalt                   :: !Int
     }
     deriving (Int -> BlockFetchConfiguration -> ShowS
[BlockFetchConfiguration] -> ShowS
BlockFetchConfiguration -> String
(Int -> BlockFetchConfiguration -> ShowS)
-> (BlockFetchConfiguration -> String)
-> ([BlockFetchConfiguration] -> ShowS)
-> Show BlockFetchConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockFetchConfiguration -> ShowS
showsPrec :: Int -> BlockFetchConfiguration -> ShowS
$cshow :: BlockFetchConfiguration -> String
show :: BlockFetchConfiguration -> String
$cshowList :: [BlockFetchConfiguration] -> ShowS
showList :: [BlockFetchConfiguration] -> ShowS
Show)

-- | Execute the block fetch logic. It monitors the current chain and candidate
-- chains. It decided which block bodies to fetch and manages the process of
-- fetching them, including making alternative decisions based on timeouts and
-- failures.
--
-- This runs forever and should be shut down using mechanisms such as async.
--
blockFetchLogic :: forall addr header block m.
                   ( HasHeader header
                   , HasHeader block
                   , HeaderHash header ~ HeaderHash block
                   , MonadDelay m
                   , MonadSTM m
                   , Ord addr
                   , Hashable addr
                   )
                => Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
                -> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
                -> BlockFetchConsensusInterface addr header block m
                -> FetchClientRegistry addr header block m
                -> BlockFetchConfiguration
                -> m Void
blockFetchLogic :: forall addr header block (m :: * -> *).
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadDelay m, MonadSTM m,
 Ord addr, Hashable addr) =>
Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-> BlockFetchConsensusInterface addr header block m
-> FetchClientRegistry addr header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
clientStateTracer
                BlockFetchConsensusInterface{STM m (Map addr (AnchoredFragment header))
STM m (AnchoredFragment header)
STM m MaxSlotNo
STM m FetchMode
STM m (Point block -> Bool)
STM m (Point block -> block -> m ())
header -> SizeInBytes
header -> block -> Bool
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
FromConsensus header -> STM m UTCTime
FromConsensus block -> STM m UTCTime
readCandidateChains :: STM m (Map addr (AnchoredFragment header))
readCurrentChain :: STM m (AnchoredFragment header)
readFetchMode :: STM m FetchMode
readFetchedBlocks :: STM m (Point block -> Bool)
mkAddFetchedBlock :: STM m (Point block -> block -> m ())
readFetchedMaxSlotNo :: STM m MaxSlotNo
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
blockFetchSize :: header -> SizeInBytes
blockMatchesHeader :: header -> block -> Bool
headerForgeUTCTime :: FromConsensus header -> STM m UTCTime
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
blockFetchSize :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> SizeInBytes
blockForgeUTCTime :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> FromConsensus block -> STM m UTCTime
blockMatchesHeader :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> header -> block -> Bool
compareCandidateChains :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
   AnchoredFragment header -> AnchoredFragment header -> Ordering
headerForgeUTCTime :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> FromConsensus header -> STM m UTCTime
mkAddFetchedBlock :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> block -> m ())
plausibleCandidateChain :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> HasCallStack =>
   AnchoredFragment header -> AnchoredFragment header -> Bool
readCandidateChains :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Map peer (AnchoredFragment header))
readCurrentChain :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (AnchoredFragment header)
readFetchMode :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m FetchMode
readFetchedBlocks :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m
-> STM m (Point block -> Bool)
readFetchedMaxSlotNo :: forall peer header block (m :: * -> *).
BlockFetchConsensusInterface peer header block m -> STM m MaxSlotNo
..}
                FetchClientRegistry addr header block m
registry
                BlockFetchConfiguration{Int
Word
DiffTime
bfcMaxConcurrencyBulkSync :: BlockFetchConfiguration -> Word
bfcMaxConcurrencyDeadline :: BlockFetchConfiguration -> Word
bfcMaxRequestsInflight :: BlockFetchConfiguration -> Word
bfcDecisionLoopInterval :: BlockFetchConfiguration -> DiffTime
bfcSalt :: BlockFetchConfiguration -> Int
bfcMaxConcurrencyBulkSync :: Word
bfcMaxConcurrencyDeadline :: Word
bfcMaxRequestsInflight :: Word
bfcDecisionLoopInterval :: DiffTime
bfcSalt :: Int
..} = do

    FetchClientRegistry addr header block m
-> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-> STM m (FetchClientPolicy header block m)
-> m ()
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> STM m (FetchClientPolicy header block m)
-> m ()
setFetchClientContext FetchClientRegistry addr header block m
registry Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
clientStateTracer STM m (FetchClientPolicy header block m)
mkFetchClientPolicy

    Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables addr header m
-> FetchNonTriggerVariables addr header block m
-> m Void
forall header block (m :: * -> *) peer.
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadDelay m, MonadSTM m,
 Ord peer, Hashable peer) =>
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> m Void
fetchLogicIterations
      Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
clientStateTracer
      FetchDecisionPolicy header
fetchDecisionPolicy
      FetchTriggerVariables addr header m
fetchTriggerVariables
      FetchNonTriggerVariables addr header block m
fetchNonTriggerVariables
  where
    mkFetchClientPolicy :: STM m (FetchClientPolicy header block m)
    mkFetchClientPolicy :: STM m (FetchClientPolicy header block m)
mkFetchClientPolicy = do
      addFetchedBlock <- STM m (Point block -> block -> m ())
mkAddFetchedBlock
      pure FetchClientPolicy {
          blockFetchSize,
          blockMatchesHeader,
          addFetchedBlock,
          blockForgeUTCTime
        }

    fetchDecisionPolicy :: FetchDecisionPolicy header
    fetchDecisionPolicy :: FetchDecisionPolicy header
fetchDecisionPolicy =
      FetchDecisionPolicy {
        maxInFlightReqsPerPeer :: Word
maxInFlightReqsPerPeer   = Word
bfcMaxRequestsInflight,
        maxConcurrencyBulkSync :: Word
maxConcurrencyBulkSync   = Word
bfcMaxConcurrencyBulkSync,
        maxConcurrencyDeadline :: Word
maxConcurrencyDeadline   = Word
bfcMaxConcurrencyDeadline,
        decisionLoopInterval :: DiffTime
decisionLoopInterval     = DiffTime
bfcDecisionLoopInterval,
        peerSalt :: Int
peerSalt                 = Int
bfcSalt,

        HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Bool
plausibleCandidateChain,
        HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains :: HasCallStack =>
AnchoredFragment header -> AnchoredFragment header -> Ordering
compareCandidateChains,
        header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize
      }

    fetchTriggerVariables :: FetchTriggerVariables addr header m
    fetchTriggerVariables :: FetchTriggerVariables addr header m
fetchTriggerVariables =
      FetchTriggerVariables {
        readStateCurrentChain :: STM m (AnchoredFragment header)
readStateCurrentChain    = STM m (AnchoredFragment header)
readCurrentChain,
        readStateCandidateChains :: STM m (Map addr (AnchoredFragment header))
readStateCandidateChains = STM m (Map addr (AnchoredFragment header))
readCandidateChains,
        readStatePeerStatus :: STM m (Map addr (PeerFetchStatus header))
readStatePeerStatus      = FetchClientRegistry addr header block m
-> STM m (Map addr (PeerFetchStatus header))
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> STM m (Map peer (PeerFetchStatus header))
readFetchClientsStatus FetchClientRegistry addr header block m
registry
      }

    fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m
    fetchNonTriggerVariables :: FetchNonTriggerVariables addr header block m
fetchNonTriggerVariables =
      FetchNonTriggerVariables {
        readStateFetchedBlocks :: STM m (Point block -> Bool)
readStateFetchedBlocks    = STM m (Point block -> Bool)
readFetchedBlocks,
        readStatePeerStateVars :: STM m (Map addr (FetchClientStateVars m header))
readStatePeerStateVars    = FetchClientRegistry addr header block m
-> STM m (Map addr (FetchClientStateVars m header))
forall (m :: * -> *) peer header block.
MonadSTM m =>
FetchClientRegistry peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
readFetchClientsStateVars FetchClientRegistry addr header block m
registry,
        readStatePeerGSVs :: STM m (Map addr PeerGSV)
readStatePeerGSVs         = FetchClientRegistry addr header block m -> STM m (Map addr PeerGSV)
forall block header (m :: * -> *) peer.
(MonadSTM m, Ord peer) =>
FetchClientRegistry peer header block m -> STM m (Map peer PeerGSV)
readPeerGSVs FetchClientRegistry addr header block m
registry,
        readStateFetchMode :: STM m FetchMode
readStateFetchMode        = STM m FetchMode
readFetchMode,
        readStateFetchedMaxSlotNo :: STM m MaxSlotNo
readStateFetchedMaxSlotNo = STM m MaxSlotNo
readFetchedMaxSlotNo
      }