{-# LANGUAGE BangPatterns     #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns   #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE TypeFamilies     #-}

module Ouroboros.Network.BlockFetch.State
  ( fetchLogicIterations
  , FetchDecisionPolicy (..)
  , FetchTriggerVariables (..)
  , FetchNonTriggerVariables (..)
  , FetchDecision
  , FetchDecline (..)
  , FetchMode (..)
  , TraceLabelPeer (..)
  , TraceFetchClientState (..)
  ) where

import           Data.Functor.Contravariant (contramap)
import           Data.Hashable (Hashable)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Data.Void

import           Control.Exception (assert)
import           Control.Monad.Class.MonadSTM
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer
import           Control.Tracer (Tracer, traceWith)

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block

import           Ouroboros.Network.BlockFetch.ClientState
                     (FetchClientStateVars (..), FetchRequest (..),
                     PeerFetchInFlight (..), PeerFetchStatus (..),
                     TraceFetchClientState (..), TraceLabelPeer (..),
                     addNewFetchRequest, readFetchClientState)
import           Ouroboros.Network.BlockFetch.Decision (FetchDecision,
                     FetchDecisionPolicy (..), FetchDecline (..),
                     FetchMode (..), PeerInfo, fetchDecisions)
import           Ouroboros.Network.BlockFetch.DeltaQ (PeerGSV (..))


fetchLogicIterations
  :: ( HasHeader header
     , HasHeader block
     , HeaderHash header ~ HeaderHash block
     , MonadDelay m
     , MonadMonotonicTime 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 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 peer (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
                     FetchDecisionPolicy header
fetchDecisionPolicy
                     FetchTriggerVariables peer header m
fetchTriggerVariables
                     FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables =

    FetchStateFingerprint peer header block
-> (FetchStateFingerprint peer header block
    -> m (FetchStateFingerprint peer header block))
-> m Void
forall (m :: * -> *) a. Monad m => a -> (a -> m a) -> m Void
iterateForever FetchStateFingerprint peer header block
forall peer header block. FetchStateFingerprint peer header block
initialFetchStateFingerprint ((FetchStateFingerprint peer header block
  -> m (FetchStateFingerprint peer header block))
 -> m Void)
-> (FetchStateFingerprint peer header block
    -> m (FetchStateFingerprint peer header block))
-> m Void
forall a b. (a -> b) -> a -> b
$ \FetchStateFingerprint peer header block
stateFingerprint -> do

      -- Run a single iteration of the fetch logic:
      --
      -- + wait for the state to change and make decisions for the new state
      -- + act on those decisions
      Time
start <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      FetchStateFingerprint peer header block
stateFingerprint' <- Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> m (FetchStateFingerprint peer header block)
forall peer (m :: * -> *) header block.
(Hashable peer, MonadSTM m, Ord peer, HasHeader header,
 HasHeader block, HeaderHash header ~ HeaderHash block) =>
Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> m (FetchStateFingerprint peer header block)
fetchLogicIteration
        Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
        FetchDecisionPolicy header
fetchDecisionPolicy
        FetchTriggerVariables peer header m
fetchTriggerVariables
        FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables
        FetchStateFingerprint peer header block
stateFingerprint
      Time
end <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      let delta :: DiffTime
delta = Time -> Time -> DiffTime
diffTime Time
end Time
start
      -- Limit decision is made once every decisionLoopInterval.
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ (FetchDecisionPolicy header -> DiffTime
forall header. FetchDecisionPolicy header -> DiffTime
decisionLoopInterval FetchDecisionPolicy header
fetchDecisionPolicy) DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
delta
      FetchStateFingerprint peer header block
-> m (FetchStateFingerprint peer header block)
forall (m :: * -> *) a. Monad m => a -> m a
return FetchStateFingerprint peer header block
stateFingerprint'


iterateForever :: Monad m => a -> (a -> m a) -> m Void
iterateForever :: a -> (a -> m a) -> m Void
iterateForever a
x0 a -> m a
m = a -> m Void
go a
x0 where go :: a -> m Void
go a
x = a -> m a
m a
x m a -> (a -> m Void) -> m Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m Void
go


-- | A single iteration of the fetch logic.
--
-- This involves:
--
-- * waiting for the state that the fetch decisions depend upon to change;
-- * taking a snapshot of the state;
-- * deciding for each peer if we will initiate a new fetch request
--
fetchLogicIteration
  :: (Hashable peer, MonadSTM m, Ord peer,
      HasHeader header, HasHeader block,
      HeaderHash header ~ HeaderHash block)
  => Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
  -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
  -> FetchDecisionPolicy header
  -> FetchTriggerVariables peer header m
  -> FetchNonTriggerVariables peer header block m
  -> FetchStateFingerprint peer header block
  -> m (FetchStateFingerprint peer header block)
fetchLogicIteration :: Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> m (FetchStateFingerprint peer header block)
fetchLogicIteration Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
decisionTracer Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
                    FetchDecisionPolicy header
fetchDecisionPolicy
                    FetchTriggerVariables peer header m
fetchTriggerVariables
                    FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables
                    FetchStateFingerprint peer header block
stateFingerprint = do

    -- Gather a snapshot of all the state we need.
    (FetchStateSnapshot peer header block m
stateSnapshot, FetchStateFingerprint peer header block
stateFingerprint') <-
      STM
  m
  (FetchStateSnapshot peer header block m,
   FetchStateFingerprint peer header block)
-> m (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (FetchStateSnapshot peer header block m,
    FetchStateFingerprint peer header block)
 -> m (FetchStateSnapshot peer header block m,
       FetchStateFingerprint peer header block))
-> STM
     m
     (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
-> m (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
forall a b. (a -> b) -> a -> b
$
        FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> STM
     m
     (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
forall (m :: * -> *) peer header block.
(MonadSTM m, Eq peer, HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block) =>
FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> STM
     m
     (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
readStateVariables
          FetchTriggerVariables peer header m
fetchTriggerVariables
          FetchNonTriggerVariables peer header block m
fetchNonTriggerVariables
          FetchStateFingerprint peer header block
stateFingerprint

    -- TODO: allow for boring PeerFetchStatusBusy transitions where we go round
    -- again rather than re-evaluating everything.
    Bool -> m () -> m ()
forall a. HasCallStack => Bool -> a -> a
assert (FetchStateFingerprint peer header block
stateFingerprint' FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
forall a. Eq a => a -> a -> Bool
/= FetchStateFingerprint peer header block
stateFingerprint) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- TODO: log the difference in the fingerprint that caused us to wake up

    -- Make all the fetch decisions
    let decisions :: [(FetchDecision (FetchRequest header),
  PeerInfo header peer (FetchClientStateVars m header, peer))]
decisions = FetchDecisionPolicy header
-> FetchStateSnapshot peer header block m
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall header block peer (m :: * -> *).
(HasHeader header, HeaderHash header ~ HeaderHash block, Ord peer,
 Hashable peer) =>
FetchDecisionPolicy header
-> FetchStateSnapshot peer header block m
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
fetchDecisionsForStateSnapshot
                      FetchDecisionPolicy header
fetchDecisionPolicy
                      FetchStateSnapshot peer header block m
stateSnapshot

    -- If we want to trace timings, we can do it here after forcing:
    -- _ <- evaluate (force decisions)

    -- Trace the batch of fetch decisions
    Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
-> [TraceLabelPeer peer (FetchDecision [Point header])] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [TraceLabelPeer peer (FetchDecision [Point header])]
decisionTracer
      [ peer
-> FetchDecision [Point header]
-> TraceLabelPeer peer (FetchDecision [Point header])
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer peer
peer ((FetchRequest header -> [Point header])
-> FetchDecision (FetchRequest header)
-> FetchDecision [Point header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FetchRequest header -> [Point header]
forall hdr. HasHeader hdr => FetchRequest hdr -> [Point hdr]
fetchRequestPoints FetchDecision (FetchRequest header)
decision)
      | (FetchDecision (FetchRequest header)
decision, (PeerFetchStatus header
_, PeerFetchInFlight header
_, PeerGSV
_, peer
peer, (FetchClientStateVars m header, peer)
_)) <- [(FetchDecision (FetchRequest header),
  PeerInfo header peer (FetchClientStateVars m header, peer))]
decisions ]

    -- Tell the fetch clients to act on our decisions
    [(peer, PeerFetchStatus header)]
statusUpdates <- Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> [(FetchDecision (FetchRequest header), PeerGSV,
     FetchClientStateVars m header, peer)]
-> m [(peer, PeerFetchStatus header)]
forall (m :: * -> *) header peer.
(MonadSTM m, HasHeader header) =>
Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> [(FetchDecision (FetchRequest header), PeerGSV,
     FetchClientStateVars m header, peer)]
-> m [(peer, PeerFetchStatus header)]
fetchLogicIterationAct Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer
                                            FetchDecisionPolicy header
fetchDecisionPolicy
                                            (((FetchDecision (FetchRequest header),
  PeerInfo header peer (FetchClientStateVars m header, peer))
 -> (FetchDecision (FetchRequest header), PeerGSV,
     FetchClientStateVars m header, peer))
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header), PeerGSV,
     FetchClientStateVars m header, peer)]
forall a b. (a -> b) -> [a] -> [b]
map (FetchDecision (FetchRequest header),
 PeerInfo header peer (FetchClientStateVars m header, peer))
-> (FetchDecision (FetchRequest header), PeerGSV,
    FetchClientStateVars m header, peer)
forall a a b b d c d. (a, (a, b, b, d, (c, d))) -> (a, b, c, d)
swizzleReqVar [(FetchDecision (FetchRequest header),
  PeerInfo header peer (FetchClientStateVars m header, peer))]
decisions)
    let !stateFingerprint'' :: FetchStateFingerprint peer header block
stateFingerprint'' =
          [(peer, PeerFetchStatus header)]
-> FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block
forall peer header block.
Ord peer =>
[(peer, PeerFetchStatus header)]
-> FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block
updateFetchStateFingerprintPeerStatus [(peer, PeerFetchStatus header)]
statusUpdates FetchStateFingerprint peer header block
stateFingerprint'

    FetchStateFingerprint peer header block
-> m (FetchStateFingerprint peer header block)
forall (m :: * -> *) a. Monad m => a -> m a
return FetchStateFingerprint peer header block
stateFingerprint''
  where
    swizzleReqVar :: (a, (a, b, b, d, (c, d))) -> (a, b, c, d)
swizzleReqVar (a
d,(a
_,b
_,b
g,d
_,(c
rq,d
p))) = (a
d,b
g,c
rq,d
p)

    fetchRequestPoints :: HasHeader hdr => FetchRequest hdr -> [Point hdr]
    fetchRequestPoints :: FetchRequest hdr -> [Point hdr]
fetchRequestPoints (FetchRequest [AnchoredFragment hdr]
headerss) =
      -- Flatten multiple fragments and trace points, not full headers
      [ hdr -> Point hdr
forall block. HasHeader block => block -> Point block
blockPoint hdr
header
      | AnchoredFragment hdr
headers <- [AnchoredFragment hdr]
headerss
      , hdr
header  <- AnchoredFragment hdr -> [hdr]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment hdr
headers ]

-- | Do a bit of rearranging of data before calling 'fetchDecisions' to do the
-- real work.
--
fetchDecisionsForStateSnapshot
  :: (HasHeader header,
      HeaderHash header ~ HeaderHash block,
      Ord peer,
      Hashable peer)
  => FetchDecisionPolicy header
  -> FetchStateSnapshot peer header block m
  -> [( FetchDecision (FetchRequest header),
        PeerInfo header peer (FetchClientStateVars m header, peer)
      )]

fetchDecisionsForStateSnapshot :: FetchDecisionPolicy header
-> FetchStateSnapshot peer header block m
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
fetchDecisionsForStateSnapshot
    FetchDecisionPolicy header
fetchDecisionPolicy
    FetchStateSnapshot {
      AnchoredFragment header
fetchStateCurrentChain :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m -> AnchoredFragment header
fetchStateCurrentChain :: AnchoredFragment header
fetchStateCurrentChain,
      Map peer (AnchoredFragment header)
fetchStatePeerChains :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m
-> Map peer (AnchoredFragment header)
fetchStatePeerChains :: Map peer (AnchoredFragment header)
fetchStatePeerChains,
      Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m
-> Map
     peer
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
fetchStatePeerStates :: Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates,
      Map peer PeerGSV
fetchStatePeerGSVs :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m -> Map peer PeerGSV
fetchStatePeerGSVs :: Map peer PeerGSV
fetchStatePeerGSVs,
      Point block -> Bool
fetchStateFetchedBlocks :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m -> Point block -> Bool
fetchStateFetchedBlocks :: Point block -> Bool
fetchStateFetchedBlocks,
      MaxSlotNo
fetchStateFetchedMaxSlotNo :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m -> MaxSlotNo
fetchStateFetchedMaxSlotNo :: MaxSlotNo
fetchStateFetchedMaxSlotNo,
      FetchMode
fetchStateFetchMode :: forall peer header block (m :: * -> *).
FetchStateSnapshot peer header block m -> FetchMode
fetchStateFetchMode :: FetchMode
fetchStateFetchMode
    } =
    Bool
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a. HasCallStack => Bool -> a -> a
assert (                 Map peer (AnchoredFragment header) -> Set peer
forall k a. Map k a -> Set k
Map.keysSet Map peer (AnchoredFragment header)
fetchStatePeerChains
            Set peer -> Set peer -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
-> Set peer
forall k a. Map k a -> Set k
Map.keysSet Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates) ([(FetchDecision (FetchRequest header),
   PeerInfo header peer (FetchClientStateVars m header, peer))]
 -> [(FetchDecision (FetchRequest header),
      PeerInfo header peer (FetchClientStateVars m header, peer))])
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a b. (a -> b) -> a -> b
$

    Bool
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a. HasCallStack => Bool -> a -> a
assert (                 Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
-> Set peer
forall k a. Map k a -> Set k
Map.keysSet Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates
            Set peer -> Set peer -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Map peer PeerGSV -> Set peer
forall k a. Map k a -> Set k
Map.keysSet Map peer PeerGSV
fetchStatePeerGSVs) ([(FetchDecision (FetchRequest header),
   PeerInfo header peer (FetchClientStateVars m header, peer))]
 -> [(FetchDecision (FetchRequest header),
      PeerInfo header peer (FetchClientStateVars m header, peer))])
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a b. (a -> b) -> a -> b
$

    FetchDecisionPolicy header
-> FetchMode
-> AnchoredFragment header
-> (Point block -> Bool)
-> MaxSlotNo
-> [(AnchoredFragment header,
     PeerInfo header peer (FetchClientStateVars m header, peer))]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall peer header block extra.
(Ord peer, Hashable peer, HasHeader header,
 HeaderHash header ~ HeaderHash block) =>
FetchDecisionPolicy header
-> FetchMode
-> AnchoredFragment header
-> (Point block -> Bool)
-> MaxSlotNo
-> [(AnchoredFragment header, PeerInfo header peer extra)]
-> [(FetchDecision (FetchRequest header),
     PeerInfo header peer extra)]
fetchDecisions
      FetchDecisionPolicy header
fetchDecisionPolicy
      FetchMode
fetchStateFetchMode
      AnchoredFragment header
fetchStateCurrentChain
      Point block -> Bool
fetchStateFetchedBlocks
      MaxSlotNo
fetchStateFetchedMaxSlotNo
      [(AnchoredFragment header,
  PeerInfo header peer (FetchClientStateVars m header, peer))]
peerChainsAndPeerInfo
  where
    peerChainsAndPeerInfo :: [(AnchoredFragment header,
  PeerInfo header peer (FetchClientStateVars m header, peer))]
peerChainsAndPeerInfo =
      ((peer,
  ((AnchoredFragment header,
    (PeerFetchStatus header, PeerFetchInFlight header,
     FetchClientStateVars m header)),
   PeerGSV))
 -> (AnchoredFragment header,
     PeerInfo header peer (FetchClientStateVars m header, peer)))
-> [(peer,
     ((AnchoredFragment header,
       (PeerFetchStatus header, PeerFetchInFlight header,
        FetchClientStateVars m header)),
      PeerGSV))]
-> [(AnchoredFragment header,
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a b. (a -> b) -> [a] -> [b]
map (peer,
 ((AnchoredFragment header,
   (PeerFetchStatus header, PeerFetchInFlight header,
    FetchClientStateVars m header)),
  PeerGSV))
-> (AnchoredFragment header,
    PeerInfo header peer (FetchClientStateVars m header, peer))
forall b a a b a c.
(b, ((a, (a, b, a)), c)) -> (a, (a, b, c, b, (a, b)))
swizzle ([(peer,
   ((AnchoredFragment header,
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)),
    PeerGSV))]
 -> [(AnchoredFragment header,
      PeerInfo header peer (FetchClientStateVars m header, peer))])
-> (Map
      peer
      ((AnchoredFragment header,
        (PeerFetchStatus header, PeerFetchInFlight header,
         FetchClientStateVars m header)),
       PeerGSV)
    -> [(peer,
         ((AnchoredFragment header,
           (PeerFetchStatus header, PeerFetchInFlight header,
            FetchClientStateVars m header)),
          PeerGSV))])
-> Map
     peer
     ((AnchoredFragment header,
       (PeerFetchStatus header, PeerFetchInFlight header,
        FetchClientStateVars m header)),
      PeerGSV)
-> [(AnchoredFragment header,
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map
  peer
  ((AnchoredFragment header,
    (PeerFetchStatus header, PeerFetchInFlight header,
     FetchClientStateVars m header)),
   PeerGSV)
-> [(peer,
     ((AnchoredFragment header,
       (PeerFetchStatus header, PeerFetchInFlight header,
        FetchClientStateVars m header)),
      PeerGSV))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map
   peer
   ((AnchoredFragment header,
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)),
    PeerGSV)
 -> [(AnchoredFragment header,
      PeerInfo header peer (FetchClientStateVars m header, peer))])
-> Map
     peer
     ((AnchoredFragment header,
       (PeerFetchStatus header, PeerFetchInFlight header,
        FetchClientStateVars m header)),
      PeerGSV)
-> [(AnchoredFragment header,
     PeerInfo header peer (FetchClientStateVars m header, peer))]
forall a b. (a -> b) -> a -> b
$
      ((AnchoredFragment header,
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header))
 -> PeerGSV
 -> ((AnchoredFragment header,
      (PeerFetchStatus header, PeerFetchInFlight header,
       FetchClientStateVars m header)),
     PeerGSV))
-> Map
     peer
     (AnchoredFragment header,
      (PeerFetchStatus header, PeerFetchInFlight header,
       FetchClientStateVars m header))
-> Map peer PeerGSV
-> Map
     peer
     ((AnchoredFragment header,
       (PeerFetchStatus header, PeerFetchInFlight header,
        FetchClientStateVars m header)),
      PeerGSV)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,)
        ((AnchoredFragment header
 -> (PeerFetchStatus header, PeerFetchInFlight header,
     FetchClientStateVars m header)
 -> (AnchoredFragment header,
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)))
-> Map peer (AnchoredFragment header)
-> Map
     peer
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
-> Map
     peer
     (AnchoredFragment header,
      (PeerFetchStatus header, PeerFetchInFlight header,
       FetchClientStateVars m header))
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map peer (AnchoredFragment header)
fetchStatePeerChains Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates)
        Map peer PeerGSV
fetchStatePeerGSVs

    swizzle :: (b, ((a, (a, b, a)), c)) -> (a, (a, b, c, b, (a, b)))
swizzle (b
peer, ((a
chain, (a
status, b
inflight, a
vars)), c
gsvs)) =
      (a
chain, (a
status, b
inflight, c
gsvs, b
peer, (a
vars, b
peer)))


-- | Act on decisions to send new requests. In fact all we do here is update
-- request variables that are shared with the threads running the block fetch
-- protocol with each peer.
--
fetchLogicIterationAct :: (MonadSTM m, HasHeader header)
                       => Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
                       -> FetchDecisionPolicy header
                       -> [(FetchDecision (FetchRequest header),
                            PeerGSV,
                            FetchClientStateVars m header,
                            peer)]
                       -> m [(peer, PeerFetchStatus header)]
fetchLogicIterationAct :: Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> FetchDecisionPolicy header
-> [(FetchDecision (FetchRequest header), PeerGSV,
     FetchClientStateVars m header, peer)]
-> m [(peer, PeerFetchStatus header)]
fetchLogicIterationAct Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer FetchDecisionPolicy{header -> SizeInBytes
blockFetchSize :: forall header. FetchDecisionPolicy header -> header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize}
                       [(FetchDecision (FetchRequest header), PeerGSV,
  FetchClientStateVars m header, peer)]
decisions =
    [m (peer, PeerFetchStatus header)]
-> m [(peer, PeerFetchStatus header)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ (,) peer
peer (PeerFetchStatus header -> (peer, PeerFetchStatus header))
-> m (PeerFetchStatus header) -> m (peer, PeerFetchStatus header)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (TraceFetchClientState header)
-> (header -> SizeInBytes)
-> FetchRequest header
-> PeerGSV
-> FetchClientStateVars m header
-> m (PeerFetchStatus header)
forall (m :: * -> *) header.
(MonadSTM m, HasHeader header) =>
Tracer m (TraceFetchClientState header)
-> (header -> SizeInBytes)
-> FetchRequest header
-> PeerGSV
-> FetchClientStateVars m header
-> m (PeerFetchStatus header)
addNewFetchRequest
                       ((TraceFetchClientState header
 -> TraceLabelPeer peer (TraceFetchClientState header))
-> Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
-> Tracer m (TraceFetchClientState header)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (peer
-> TraceFetchClientState header
-> TraceLabelPeer peer (TraceFetchClientState header)
forall peerid a. peerid -> a -> TraceLabelPeer peerid a
TraceLabelPeer peer
peer) Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
clientStateTracer)
                       header -> SizeInBytes
blockFetchSize
                       FetchRequest header
request PeerGSV
gsvs
                       FetchClientStateVars m header
stateVars
      | (Right FetchRequest header
request, PeerGSV
gsvs, FetchClientStateVars m header
stateVars, peer
peer) <- [(FetchDecision (FetchRequest header), PeerGSV,
  FetchClientStateVars m header, peer)]
decisions ]


-- | STM actions to read various state variables that the fetch logic depends
-- upon. Any change in these variables is a trigger to re-evaluate the decision
-- on what blocks to fetch.
--
-- Note that this is a \"level trigger\" not an \"edge trigger\": we do not
-- have to re-evaluate on every change, it is sufficient to re-evaluate at some
-- stage after one or more changes. This means it is ok to get somewhat behind,
-- and it is not necessary to determine exactly what changed, just that there
-- was some change.
--
data FetchTriggerVariables peer header m = FetchTriggerVariables {
       FetchTriggerVariables peer header m
-> STM m (AnchoredFragment header)
readStateCurrentChain    :: STM m (AnchoredFragment header),
       FetchTriggerVariables peer header m
-> STM m (Map peer (AnchoredFragment header))
readStateCandidateChains :: STM m (Map peer (AnchoredFragment header)),
       FetchTriggerVariables peer header m
-> STM m (Map peer (PeerFetchStatus header))
readStatePeerStatus      :: STM m (Map peer (PeerFetchStatus header))
     }

-- | STM actions to read various state variables that the fetch logic uses.
-- While the decisions do make use of the values of these variables, it is not
-- necessary to re-evaluate when these variables change.
--
data FetchNonTriggerVariables peer header block m = FetchNonTriggerVariables {
       FetchNonTriggerVariables peer header block m
-> STM m (Point block -> Bool)
readStateFetchedBlocks    :: STM m (Point block -> Bool),
       FetchNonTriggerVariables peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
readStatePeerStateVars    :: STM m (Map peer (FetchClientStateVars m header)),
       FetchNonTriggerVariables peer header block m
-> STM m (Map peer PeerGSV)
readStatePeerGSVs         :: STM m (Map peer PeerGSV),
       FetchNonTriggerVariables peer header block m -> STM m FetchMode
readStateFetchMode        :: STM m FetchMode,
       FetchNonTriggerVariables peer header block m -> STM m MaxSlotNo
readStateFetchedMaxSlotNo :: STM m MaxSlotNo
     }


data FetchStateFingerprint peer header block =
     FetchStateFingerprint
       !(Maybe (Point block))
       !(Map peer (Point header))
       !(Map peer (PeerFetchStatus header))
  deriving FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
(FetchStateFingerprint peer header block
 -> FetchStateFingerprint peer header block -> Bool)
-> (FetchStateFingerprint peer header block
    -> FetchStateFingerprint peer header block -> Bool)
-> Eq (FetchStateFingerprint peer header block)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall peer header block.
(StandardHash block, StandardHash header, Eq peer) =>
FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
/= :: FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
$c/= :: forall peer header block.
(StandardHash block, StandardHash header, Eq peer) =>
FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
== :: FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
$c== :: forall peer header block.
(StandardHash block, StandardHash header, Eq peer) =>
FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
Eq

initialFetchStateFingerprint :: FetchStateFingerprint peer header block
initialFetchStateFingerprint :: FetchStateFingerprint peer header block
initialFetchStateFingerprint =
    Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
forall peer header block.
Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
FetchStateFingerprint
      Maybe (Point block)
forall a. Maybe a
Nothing
      Map peer (Point header)
forall k a. Map k a
Map.empty
      Map peer (PeerFetchStatus header)
forall k a. Map k a
Map.empty

updateFetchStateFingerprintPeerStatus :: Ord peer
                                      => [(peer, PeerFetchStatus header)]
                                      -> FetchStateFingerprint peer header block
                                      -> FetchStateFingerprint peer header block
updateFetchStateFingerprintPeerStatus :: [(peer, PeerFetchStatus header)]
-> FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block
updateFetchStateFingerprintPeerStatus [(peer, PeerFetchStatus header)]
statuses'
    (FetchStateFingerprint Maybe (Point block)
current Map peer (Point header)
candidates Map peer (PeerFetchStatus header)
statuses) =
    Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
forall peer header block.
Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
FetchStateFingerprint
      Maybe (Point block)
current
      Map peer (Point header)
candidates
      (Map peer (PeerFetchStatus header)
-> Map peer (PeerFetchStatus header)
-> Map peer (PeerFetchStatus header)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([(peer, PeerFetchStatus header)]
-> Map peer (PeerFetchStatus header)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(peer, PeerFetchStatus header)]
statuses') Map peer (PeerFetchStatus header)
statuses) -- left overrides right

-- |
--
-- Note that the domain of 'fetchStatePeerChains' is a subset of the domain
-- of 'fetchStatePeerStates' and 'fetchStatePeerReqVars'.
--
data FetchStateSnapshot peer header block m = FetchStateSnapshot {
       FetchStateSnapshot peer header block m -> AnchoredFragment header
fetchStateCurrentChain     :: AnchoredFragment header,
       FetchStateSnapshot peer header block m
-> Map peer (AnchoredFragment header)
fetchStatePeerChains       :: Map peer (AnchoredFragment header),
       FetchStateSnapshot peer header block m
-> Map
     peer
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
fetchStatePeerStates       :: Map peer (PeerFetchStatus   header,
                                               PeerFetchInFlight header,
                                               FetchClientStateVars m header),
       FetchStateSnapshot peer header block m -> Map peer PeerGSV
fetchStatePeerGSVs         :: Map peer PeerGSV,
       FetchStateSnapshot peer header block m -> Point block -> Bool
fetchStateFetchedBlocks    :: Point block -> Bool,
       FetchStateSnapshot peer header block m -> FetchMode
fetchStateFetchMode        :: FetchMode,
       FetchStateSnapshot peer header block m -> MaxSlotNo
fetchStateFetchedMaxSlotNo :: MaxSlotNo
     }

readStateVariables :: (MonadSTM m, Eq peer,
                       HasHeader header, HasHeader block,
                       HeaderHash header ~ HeaderHash block)
                   => FetchTriggerVariables peer header m
                   -> FetchNonTriggerVariables peer header block m
                   -> FetchStateFingerprint peer header block
                   -> STM m (FetchStateSnapshot peer header block m,
                             FetchStateFingerprint peer header block)
readStateVariables :: FetchTriggerVariables peer header m
-> FetchNonTriggerVariables peer header block m
-> FetchStateFingerprint peer header block
-> STM
     m
     (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
readStateVariables FetchTriggerVariables{STM m (Map peer (AnchoredFragment header))
STM m (Map peer (PeerFetchStatus header))
STM m (AnchoredFragment header)
readStatePeerStatus :: STM m (Map peer (PeerFetchStatus header))
readStateCandidateChains :: STM m (Map peer (AnchoredFragment header))
readStateCurrentChain :: STM m (AnchoredFragment header)
readStatePeerStatus :: forall peer header (m :: * -> *).
FetchTriggerVariables peer header m
-> STM m (Map peer (PeerFetchStatus header))
readStateCandidateChains :: forall peer header (m :: * -> *).
FetchTriggerVariables peer header m
-> STM m (Map peer (AnchoredFragment header))
readStateCurrentChain :: forall peer header (m :: * -> *).
FetchTriggerVariables peer header m
-> STM m (AnchoredFragment header)
..}
                   FetchNonTriggerVariables{STM m (Map peer PeerGSV)
STM m (Map peer (FetchClientStateVars m header))
STM m MaxSlotNo
STM m FetchMode
STM m (Point block -> Bool)
readStateFetchedMaxSlotNo :: STM m MaxSlotNo
readStateFetchMode :: STM m FetchMode
readStatePeerGSVs :: STM m (Map peer PeerGSV)
readStatePeerStateVars :: STM m (Map peer (FetchClientStateVars m header))
readStateFetchedBlocks :: STM m (Point block -> Bool)
readStateFetchedMaxSlotNo :: forall peer header block (m :: * -> *).
FetchNonTriggerVariables peer header block m -> STM m MaxSlotNo
readStateFetchMode :: forall peer header block (m :: * -> *).
FetchNonTriggerVariables peer header block m -> STM m FetchMode
readStatePeerGSVs :: forall peer header block (m :: * -> *).
FetchNonTriggerVariables peer header block m
-> STM m (Map peer PeerGSV)
readStatePeerStateVars :: forall peer header block (m :: * -> *).
FetchNonTriggerVariables peer header block m
-> STM m (Map peer (FetchClientStateVars m header))
readStateFetchedBlocks :: forall peer header block (m :: * -> *).
FetchNonTriggerVariables peer header block m
-> STM m (Point block -> Bool)
..}
                   FetchStateFingerprint peer header block
fetchStateFingerprint = do

    -- Read all the trigger state variables
    AnchoredFragment header
fetchStateCurrentChain  <- STM m (AnchoredFragment header)
readStateCurrentChain
    Map peer (AnchoredFragment header)
fetchStatePeerChains    <- STM m (Map peer (AnchoredFragment header))
readStateCandidateChains
    Map peer (PeerFetchStatus header)
fetchStatePeerStatus    <- STM m (Map peer (PeerFetchStatus header))
readStatePeerStatus

    -- Construct the change detection fingerprint
    let !fetchStateFingerprint' :: FetchStateFingerprint peer header block
fetchStateFingerprint' =
          Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
forall peer header block.
Maybe (Point block)
-> Map peer (Point header)
-> Map peer (PeerFetchStatus header)
-> FetchStateFingerprint peer header block
FetchStateFingerprint
            (Point block -> Maybe (Point block)
forall a. a -> Maybe a
Just (Point header -> Point block
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (AnchoredFragment header -> Point header
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment header
fetchStateCurrentChain)))
            ((AnchoredFragment header -> Point header)
-> Map peer (AnchoredFragment header) -> Map peer (Point header)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map AnchoredFragment header -> Point header
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint Map peer (AnchoredFragment header)
fetchStatePeerChains)
            Map peer (PeerFetchStatus header)
fetchStatePeerStatus

    -- Check the fingerprint changed, or block and wait until it does
    Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (FetchStateFingerprint peer header block
fetchStateFingerprint' FetchStateFingerprint peer header block
-> FetchStateFingerprint peer header block -> Bool
forall a. Eq a => a -> a -> Bool
/= FetchStateFingerprint peer header block
fetchStateFingerprint)

    -- Now read all the non-trigger state variables
    Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates       <- STM m (Map peer (FetchClientStateVars m header))
readStatePeerStateVars
                              STM m (Map peer (FetchClientStateVars m header))
-> (Map peer (FetchClientStateVars m header)
    -> STM
         m
         (Map
            peer
            (PeerFetchStatus header, PeerFetchInFlight header,
             FetchClientStateVars m header)))
-> STM
     m
     (Map
        peer
        (PeerFetchStatus header, PeerFetchInFlight header,
         FetchClientStateVars m header))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FetchClientStateVars m header
 -> STM
      m
      (PeerFetchStatus header, PeerFetchInFlight header,
       FetchClientStateVars m header))
-> Map peer (FetchClientStateVars m header)
-> STM
     m
     (Map
        peer
        (PeerFetchStatus header, PeerFetchInFlight header,
         FetchClientStateVars m header))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FetchClientStateVars m header
-> STM
     m
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
forall (m :: * -> *) header.
MonadSTM m =>
FetchClientStateVars m header
-> STM
     m
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
readFetchClientState
    Map peer PeerGSV
fetchStatePeerGSVs         <- STM m (Map peer PeerGSV)
readStatePeerGSVs
    Point block -> Bool
fetchStateFetchedBlocks    <- STM m (Point block -> Bool)
readStateFetchedBlocks
    FetchMode
fetchStateFetchMode        <- STM m FetchMode
readStateFetchMode
    MaxSlotNo
fetchStateFetchedMaxSlotNo <- STM m MaxSlotNo
readStateFetchedMaxSlotNo


    -- Construct the overall snapshot of the state
    let fetchStateSnapshot :: FetchStateSnapshot peer header block m
fetchStateSnapshot =
          FetchStateSnapshot :: forall peer header block (m :: * -> *).
AnchoredFragment header
-> Map peer (AnchoredFragment header)
-> Map
     peer
     (PeerFetchStatus header, PeerFetchInFlight header,
      FetchClientStateVars m header)
-> Map peer PeerGSV
-> (Point block -> Bool)
-> FetchMode
-> MaxSlotNo
-> FetchStateSnapshot peer header block m
FetchStateSnapshot {
            AnchoredFragment header
fetchStateCurrentChain :: AnchoredFragment header
fetchStateCurrentChain :: AnchoredFragment header
fetchStateCurrentChain,
            Map peer (AnchoredFragment header)
fetchStatePeerChains :: Map peer (AnchoredFragment header)
fetchStatePeerChains :: Map peer (AnchoredFragment header)
fetchStatePeerChains,
            Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates :: Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates :: Map
  peer
  (PeerFetchStatus header, PeerFetchInFlight header,
   FetchClientStateVars m header)
fetchStatePeerStates,
            Map peer PeerGSV
fetchStatePeerGSVs :: Map peer PeerGSV
fetchStatePeerGSVs :: Map peer PeerGSV
fetchStatePeerGSVs,
            Point block -> Bool
fetchStateFetchedBlocks :: Point block -> Bool
fetchStateFetchedBlocks :: Point block -> Bool
fetchStateFetchedBlocks,
            FetchMode
fetchStateFetchMode :: FetchMode
fetchStateFetchMode :: FetchMode
fetchStateFetchMode,
            MaxSlotNo
fetchStateFetchedMaxSlotNo :: MaxSlotNo
fetchStateFetchedMaxSlotNo :: MaxSlotNo
fetchStateFetchedMaxSlotNo
          }

    (FetchStateSnapshot peer header block m,
 FetchStateFingerprint peer header block)
-> STM
     m
     (FetchStateSnapshot peer header block m,
      FetchStateFingerprint peer header block)
forall (m :: * -> *) a. Monad m => a -> m a
return (FetchStateSnapshot peer header block m
fetchStateSnapshot, FetchStateFingerprint peer header block
fetchStateFingerprint')