{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Ouroboros.Network.BlockFetch.Client
(
blockFetchClient
, BlockFetchClient
, FetchClientContext
, TraceFetchClientState
, FetchRequest (..)
, FetchClientStateVars
, BlockFetchProtocolFailure
) where
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (assert)
import Control.Monad (unless)
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Tracer (traceWith)
import Ouroboros.Network.Block
import Network.TypedProtocol.Core
import Network.TypedProtocol.Pipelined
import Ouroboros.Network.ControlMessage (ControlMessageSTM)
import Ouroboros.Network.Protocol.BlockFetch.Type
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import Ouroboros.Network.AnchoredFragment qualified as AF
import Ouroboros.Network.BlockFetch.ClientState (FetchClientContext (..),
FetchClientPolicy (..), FetchClientStateVars (..), FetchRequest (..),
FromConsensus (..), TraceFetchClientState (..),
acknowledgeFetchRequest, completeBlockDownload, completeFetchBatch,
fetchClientCtxStateVars, rejectedFetchBatch, startedFetchBatch)
import Ouroboros.Network.BlockFetch.DeltaQ (PeerFetchInFlightLimits (..),
PeerGSV (..))
import Ouroboros.Network.PeerSelection.PeerMetric.Type (FetchedMetricsTracer)
data BlockFetchProtocolFailure =
BlockFetchProtocolFailureTooFewBlocks
| BlockFetchProtocolFailureTooManyBlocks
| BlockFetchProtocolFailureWrongBlock
| BlockFetchProtocolFailureInvalidBody
deriving (BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool
(BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool)
-> (BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool)
-> Eq BlockFetchProtocolFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool
== :: BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool
$c/= :: BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool
/= :: BlockFetchProtocolFailure -> BlockFetchProtocolFailure -> Bool
Eq, Int -> BlockFetchProtocolFailure -> ShowS
[BlockFetchProtocolFailure] -> ShowS
BlockFetchProtocolFailure -> String
(Int -> BlockFetchProtocolFailure -> ShowS)
-> (BlockFetchProtocolFailure -> String)
-> ([BlockFetchProtocolFailure] -> ShowS)
-> Show BlockFetchProtocolFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlockFetchProtocolFailure -> ShowS
showsPrec :: Int -> BlockFetchProtocolFailure -> ShowS
$cshow :: BlockFetchProtocolFailure -> String
show :: BlockFetchProtocolFailure -> String
$cshowList :: [BlockFetchProtocolFailure] -> ShowS
showList :: [BlockFetchProtocolFailure] -> ShowS
Show)
instance Exception BlockFetchProtocolFailure
type BlockFetchClient header block m a =
FetchClientContext header block m ->
PeerPipelined (BlockFetch block (Point block)) AsClient BFIdle m a
blockFetchClient :: forall header block versionNumber m.
(MonadSTM m, MonadThrow m, MonadTime m,
MonadMonotonicTime m, HasHeader header,
HasHeader block, HeaderHash header ~ HeaderHash block)
=> versionNumber
-> ControlMessageSTM m
-> FetchedMetricsTracer m
-> FetchClientContext header block m
-> PeerPipelined (BlockFetch block (Point block)) AsClient BFIdle m ()
blockFetchClient :: forall header block versionNumber (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadTime m, MonadMonotonicTime m,
HasHeader header, HasHeader block,
HeaderHash header ~ HeaderHash block) =>
versionNumber
-> ControlMessageSTM m
-> FetchedMetricsTracer m
-> FetchClientContext header block m
-> PeerPipelined
(BlockFetch block (Point block)) 'AsClient 'BFIdle m ()
blockFetchClient versionNumber
_version ControlMessageSTM m
controlMessageSTM FetchedMetricsTracer m
reportFetched
FetchClientContext {
fetchClientCtxTracer :: forall header block (m :: * -> *).
FetchClientContext header block m
-> Tracer m (TraceFetchClientState header)
fetchClientCtxTracer = Tracer m (TraceFetchClientState header)
tracer,
fetchClientCtxPolicy :: forall header block (m :: * -> *).
FetchClientContext header block m
-> FetchClientPolicy header block m
fetchClientCtxPolicy = FetchClientPolicy {
header -> SizeInBytes
blockFetchSize :: header -> SizeInBytes
blockFetchSize :: forall header block (m :: * -> *).
FetchClientPolicy header block m -> header -> SizeInBytes
blockFetchSize,
header -> block -> Bool
blockMatchesHeader :: header -> block -> Bool
blockMatchesHeader :: forall header block (m :: * -> *).
FetchClientPolicy header block m -> header -> block -> Bool
blockMatchesHeader,
Point block -> block -> m ()
addFetchedBlock :: Point block -> block -> m ()
addFetchedBlock :: forall header block (m :: * -> *).
FetchClientPolicy header block m -> Point block -> block -> m ()
addFetchedBlock,
FromConsensus block -> STM m UTCTime
blockForgeUTCTime :: FromConsensus block -> STM m UTCTime
blockForgeUTCTime :: forall header block (m :: * -> *).
FetchClientPolicy header block m
-> FromConsensus block -> STM m UTCTime
blockForgeUTCTime
},
fetchClientCtxStateVars :: forall header block (m :: * -> *).
FetchClientContext header block m -> FetchClientStateVars m header
fetchClientCtxStateVars = FetchClientStateVars m header
stateVars
} =
PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle 'Z () m ()
-> PeerPipelined
(BlockFetch block (Point block)) 'AsClient 'BFIdle m ()
forall ps (pr :: PeerRole) (st :: ps) c (m :: * -> *) a.
PeerSender ps pr st 'Z c m a -> PeerPipelined ps pr st m a
PeerPipelined (Nat 'Z
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle 'Z () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderAwait Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero)
where
senderIdle :: forall n.
Nat n
-> PeerSender (BlockFetch block (Point block)) AsClient
BFIdle n () m ()
senderIdle :: forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderIdle (Succ Nat n
outstanding) =
Maybe
(PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ())
-> (()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
forall ps (pr :: PeerRole) (st :: ps) (n1 :: N) c (m :: * -> *) a.
Maybe (PeerSender ps pr st ('S n1) c m a)
-> (c -> PeerSender ps pr st n1 c m a)
-> PeerSender ps pr st ('S n1) c m a
SenderCollect (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
-> Maybe
(PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ())
forall a. a -> Maybe a
Just (Nat ('S n)
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderAwait (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
outstanding)))
(\()
_ -> Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderIdle Nat n
outstanding)
senderIdle Nat n
Zero = Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderAwait Nat n
forall (n :: N). ('Z ~ n) => Nat n
Zero
senderAwait :: forall n.
Nat n
-> PeerSender (BlockFetch block (Point block)) AsClient
BFIdle n () m ()
senderAwait :: forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderAwait Nat n
outstanding =
m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (n :: N) c a.
m (PeerSender ps pr st n c m a) -> PeerSender ps pr st n c m a
SenderEffect (m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall a b. (a -> b) -> a -> b
$ do
result <-
Tracer m (TraceFetchClientState header)
-> ControlMessageSTM m
-> FetchClientStateVars m header
-> m (Maybe
(FetchRequest header, PeerGSV, PeerFetchInFlightLimits))
forall (m :: * -> *) header.
MonadSTM m =>
Tracer m (TraceFetchClientState header)
-> ControlMessageSTM m
-> FetchClientStateVars m header
-> m (Maybe
(FetchRequest header, PeerGSV, PeerFetchInFlightLimits))
acknowledgeFetchRequest Tracer m (TraceFetchClientState header)
tracer ControlMessageSTM m
controlMessageSTM FetchClientStateVars m header
stateVars
case result of
Maybe (FetchRequest header, PeerGSV, PeerFetchInFlightLimits)
Nothing -> do
Tracer m (TraceFetchClientState header)
-> TraceFetchClientState header -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceFetchClientState header)
tracer (Int -> TraceFetchClientState header
forall header. Int -> TraceFetchClientState header
ClientTerminating (Int -> TraceFetchClientState header)
-> Int -> TraceFetchClientState header
forall a b. (a -> b) -> a -> b
$ Nat n -> Int
forall (n :: N). Nat n -> Int
natToInt Nat n
outstanding)
PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()))
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a b. (a -> b) -> a -> b
$ Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderTerminate Nat n
outstanding
Just (FetchRequest header
request, PeerGSV
gsvs, PeerFetchInFlightLimits
inflightlimits) ->
PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()))
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a b. (a -> b) -> a -> b
$ Nat n
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderActive Nat n
outstanding PeerGSV
gsvs PeerFetchInFlightLimits
inflightlimits
(FetchRequest header -> [AnchoredFragment header]
forall header. FetchRequest header -> [AnchoredFragment header]
fetchRequestFragments FetchRequest header
request)
senderActive :: forall n.
Nat n
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender (BlockFetch block (Point block)) AsClient
BFIdle n () m ()
senderActive :: forall (n :: N).
Nat n
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderActive Nat n
outstanding PeerGSV
gsvs PeerFetchInFlightLimits
inflightlimits (AnchoredFragment header
fragment:[AnchoredFragment header]
fragments) =
m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (n :: N) c a.
m (PeerSender ps pr st n c m a) -> PeerSender ps pr st n c m a
SenderEffect (m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall a b. (a -> b) -> a -> b
$ do
let range :: ChainRange (Point header)
!range :: ChainRange (Point header)
range = Bool -> ChainRange (Point header) -> ChainRange (Point header)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Bool -> Bool
not (AnchoredFragment header -> Bool
forall v a b. AnchoredSeq v a b -> Bool
AF.null AnchoredFragment header
fragment)) (ChainRange (Point header) -> ChainRange (Point header))
-> ChainRange (Point header) -> ChainRange (Point header)
forall a b. (a -> b) -> a -> b
$
Point header -> Point header -> ChainRange (Point header)
forall point. point -> point -> ChainRange point
ChainRange (header -> Point header
forall block. HasHeader block => block -> Point block
blockPoint header
lower)
(header -> Point header
forall block. HasHeader block => block -> Point block
blockPoint header
upper)
where
Right header
lower = AnchoredFragment header -> Either (Anchor header) header
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.last AnchoredFragment header
fragment
Right header
upper = AnchoredFragment header -> Either (Anchor header) header
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Either a b
AF.head AnchoredFragment header
fragment
Tracer m (TraceFetchClientState header)
-> TraceFetchClientState header -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceFetchClientState header)
tracer (AnchoredFragment header -> PeerGSV -> TraceFetchClientState header
forall header.
AnchoredFragment header -> PeerGSV -> TraceFetchClientState header
SendFetchRequest AnchoredFragment header
fragment PeerGSV
gsvs)
PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()))
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
-> m (PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
forall a b. (a -> b) -> a -> b
$
WeHaveAgency 'AsClient 'BFIdle
-> Message (BlockFetch block (Point block)) 'BFIdle 'BFBusy
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) (st'' :: ps)
(m :: * -> *) c (n :: N) a.
WeHaveAgency pr st
-> Message ps st st'
-> PeerReceiver ps pr st' st'' m c
-> PeerSender ps pr st'' ('S n) c m a
-> PeerSender ps pr st n c m a
SenderPipeline
(ClientHasAgency 'BFIdle -> WeHaveAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle)
(ChainRange (Point block)
-> Message (BlockFetch block (Point block)) 'BFIdle 'BFBusy
forall {k} point1 (block :: k).
ChainRange point1
-> Message (BlockFetch block point1) 'BFIdle 'BFBusy
MsgRequestRange (ChainRange (Point header) -> ChainRange (Point block)
forall a b.
(HeaderHash a ~ HeaderHash b) =>
ChainRange (Point a) -> ChainRange (Point b)
castRange ChainRange (Point header)
range))
(ChainRange (Point header)
-> AnchoredFragment header
-> PeerFetchInFlightLimits
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ()
receiverBusy ChainRange (Point header)
range AnchoredFragment header
fragment PeerFetchInFlightLimits
inflightlimits)
(Nat ('S n)
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
forall (n :: N).
Nat n
-> PeerGSV
-> PeerFetchInFlightLimits
-> [AnchoredFragment header]
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderActive (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
outstanding) PeerGSV
gsvs PeerFetchInFlightLimits
inflightlimits [AnchoredFragment header]
fragments)
senderActive Nat n
outstanding PeerGSV
_ PeerFetchInFlightLimits
_ [] = Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderIdle Nat n
outstanding
senderTerminate :: forall n.
Nat n
-> PeerSender (BlockFetch block (Point block)) AsClient
BFIdle n () m ()
senderTerminate :: forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderTerminate Nat n
Zero =
WeHaveAgency 'AsClient 'BFIdle
-> Message (BlockFetch block (Point block)) 'BFIdle 'BFDone
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFDone 'Z () m ()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle 'Z () m ()
forall (pr :: PeerRole) ps (st :: ps) (st' :: ps) c (m :: * -> *)
a.
WeHaveAgency pr st
-> Message ps st st'
-> PeerSender ps pr st' 'Z c m a
-> PeerSender ps pr st 'Z c m a
SenderYield (ClientHasAgency 'BFIdle -> WeHaveAgency 'AsClient 'BFIdle
forall {ps} (st :: ps).
ClientHasAgency st -> PeerHasAgency 'AsClient st
ClientAgency ClientHasAgency 'BFIdle
forall {k} {k1} {block :: k} {point :: k1}. ClientHasAgency 'BFIdle
TokIdle)
Message (BlockFetch block (Point block)) 'BFIdle 'BFDone
forall {k} {k1} (block :: k) (point :: k1).
Message (BlockFetch block point) 'BFIdle 'BFDone
MsgClientDone
(NobodyHasAgency 'BFDone
-> ()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFDone 'Z () m ()
forall ps (st :: ps) a (pr :: PeerRole) c (m :: * -> *).
NobodyHasAgency st -> a -> PeerSender ps pr st 'Z c m a
SenderDone NobodyHasAgency 'BFDone
forall {k} {k1} {block :: k} {point :: k1}. NobodyHasAgency 'BFDone
TokDone ())
senderTerminate (Succ Nat n
n) =
Maybe
(PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ())
-> (()
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ())
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ()
forall ps (pr :: PeerRole) (st :: ps) (n1 :: N) c (m :: * -> *) a.
Maybe (PeerSender ps pr st ('S n1) c m a)
-> (c -> PeerSender ps pr st n1 c m a)
-> PeerSender ps pr st ('S n1) c m a
SenderCollect Maybe
(PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle ('S n) () m ())
forall a. Maybe a
Nothing
(\()
_ -> Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
forall (n :: N).
Nat n
-> PeerSender
(BlockFetch block (Point block)) 'AsClient 'BFIdle n () m ()
senderTerminate Nat n
n)
receiverBusy :: ChainRange (Point header)
-> AnchoredFragment header
-> PeerFetchInFlightLimits
-> PeerReceiver (BlockFetch block (Point block)) AsClient
BFBusy BFIdle m ()
receiverBusy :: ChainRange (Point header)
-> AnchoredFragment header
-> PeerFetchInFlightLimits
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ()
receiverBusy ChainRange (Point header)
range AnchoredFragment header
fragment PeerFetchInFlightLimits
inflightlimits =
TheyHaveAgency 'AsClient 'BFBusy
-> (forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFBusy st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ()
forall (pr :: PeerRole) ps (st :: ps) (stdone :: ps) (m :: * -> *)
c.
TheyHaveAgency pr st
-> (forall (st' :: ps).
Message ps st st' -> PeerReceiver ps pr st' stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverAwait
(ServerHasAgency 'BFBusy -> PeerHasAgency 'AsServer 'BFBusy
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFBusy
forall {k} {k1} {block :: k} {point :: k1}. ServerHasAgency 'BFBusy
TokBusy) ((forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFBusy st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ())
-> (forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFBusy st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient 'BFBusy 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ \Message (BlockFetch block (Point block)) 'BFBusy st'
msg ->
case Message (BlockFetch block (Point block)) 'BFBusy st'
msg of
Message (BlockFetch block (Point block)) 'BFBusy st'
R:MessageBlockFetchfromto (*) (*) block (Point block) 'BFBusy st'
MsgNoBlocks ->
m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ do
Tracer m (TraceFetchClientState header)
-> (header -> SizeInBytes)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> [header]
-> FetchClientStateVars m header
-> m ()
forall (m :: * -> *) header.
(MonadSTM m, HasHeader header) =>
Tracer m (TraceFetchClientState header)
-> (header -> SizeInBytes)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> [header]
-> FetchClientStateVars m header
-> m ()
rejectedFetchBatch Tracer m (TraceFetchClientState header)
tracer header -> SizeInBytes
blockFetchSize PeerFetchInFlightLimits
inflightlimits
ChainRange (Point header)
range [header]
headers FetchClientStateVars m header
stateVars
PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' st' m ()
forall c ps (pr :: PeerRole) (st :: ps) (m :: * -> *).
c -> PeerReceiver ps pr st st m c
ReceiverDone ())
where
headers :: [header]
headers = AnchoredFragment header -> [header]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment header
fragment
Message (BlockFetch block (Point block)) 'BFBusy st'
R:MessageBlockFetchfromto (*) (*) block (Point block) 'BFBusy st'
MsgStartBatch ->
m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ do
Tracer m (TraceFetchClientState header)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> FetchClientStateVars m header
-> m ()
forall (m :: * -> *) header.
MonadSTM m =>
Tracer m (TraceFetchClientState header)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> FetchClientStateVars m header
-> m ()
startedFetchBatch Tracer m (TraceFetchClientState header)
tracer PeerFetchInFlightLimits
inflightlimits ChainRange (Point header)
range FetchClientStateVars m header
stateVars
PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PeerFetchInFlightLimits
-> ChainRange (Point header)
-> [header]
-> PeerReceiver
(BlockFetch block (Point block))
'AsClient
'BFStreaming
'BFIdle
m
()
receiverStreaming PeerFetchInFlightLimits
inflightlimits ChainRange (Point header)
range [header]
headers)
where
headers :: [header]
headers = AnchoredFragment header -> [header]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment header
fragment
receiverStreaming :: PeerFetchInFlightLimits
-> ChainRange (Point header)
-> [header]
-> PeerReceiver (BlockFetch block (Point block)) AsClient
BFStreaming BFIdle m ()
receiverStreaming :: PeerFetchInFlightLimits
-> ChainRange (Point header)
-> [header]
-> PeerReceiver
(BlockFetch block (Point block))
'AsClient
'BFStreaming
'BFIdle
m
()
receiverStreaming PeerFetchInFlightLimits
inflightlimits ChainRange (Point header)
range [header]
headers =
TheyHaveAgency 'AsClient 'BFStreaming
-> (forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFStreaming st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block))
'AsClient
'BFStreaming
'BFIdle
m
()
forall (pr :: PeerRole) ps (st :: ps) (stdone :: ps) (m :: * -> *)
c.
TheyHaveAgency pr st
-> (forall (st' :: ps).
Message ps st st' -> PeerReceiver ps pr st' stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverAwait
(ServerHasAgency 'BFStreaming
-> PeerHasAgency 'AsServer 'BFStreaming
forall {ps} (st :: ps).
ServerHasAgency st -> PeerHasAgency 'AsServer st
ServerAgency ServerHasAgency 'BFStreaming
forall {k} {k1} {block :: k} {point :: k1}.
ServerHasAgency 'BFStreaming
TokStreaming) ((forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFStreaming st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block))
'AsClient
'BFStreaming
'BFIdle
m
())
-> (forall (st' :: BlockFetch block (Point block)).
Message (BlockFetch block (Point block)) 'BFStreaming st'
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block))
'AsClient
'BFStreaming
'BFIdle
m
()
forall a b. (a -> b) -> a -> b
$ \Message (BlockFetch block (Point block)) 'BFStreaming st'
msg ->
case (Message (BlockFetch block (Point block)) 'BFStreaming st'
msg, [header]
headers) of
(Message (BlockFetch block (Point block)) 'BFStreaming st'
R:MessageBlockFetchfromto
(*) (*) block (Point block) 'BFStreaming st'
MsgBatchDone, []) -> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ do
Tracer m (TraceFetchClientState header)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> FetchClientStateVars m header
-> m ()
forall (m :: * -> *) header.
MonadSTM m =>
Tracer m (TraceFetchClientState header)
-> PeerFetchInFlightLimits
-> ChainRange (Point header)
-> FetchClientStateVars m header
-> m ()
completeFetchBatch Tracer m (TraceFetchClientState header)
tracer PeerFetchInFlightLimits
inflightlimits ChainRange (Point header)
range FetchClientStateVars m header
stateVars
PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (()
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' st' m ()
forall c ps (pr :: PeerRole) (st :: ps) (m :: * -> *).
c -> PeerReceiver ps pr st st m c
ReceiverDone ())
(MsgBlock block1
block, header
header:[header]
headers') -> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ do
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
getCurrentTime
nowMono <- getMonotonicTime
unless (blockPoint header == castPoint (blockPoint block)) $
throwIO BlockFetchProtocolFailureWrongBlock
unless (blockMatchesHeader header block) $
throwIO BlockFetchProtocolFailureInvalidBody
addFetchedBlock (castPoint (blockPoint header)) block
forgeTime <- atomically $ blockForgeUTCTime $ FromConsensus block
let blockDelay = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
forgeTime
let hf = header -> HeaderFields header
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields header
header
slotNo = HeaderFields header -> SlotNo
forall k (b :: k). HeaderFields b -> SlotNo
headerFieldSlot HeaderFields header
hf
atomically $ traceWith reportFetched ( blockFetchSize header
, slotNo
, nowMono
)
completeBlockDownload tracer blockFetchSize inflightlimits
header blockDelay stateVars
return (receiverStreaming inflightlimits range headers')
(Message (BlockFetch block (Point block)) 'BFStreaming st'
R:MessageBlockFetchfromto
(*) (*) block (Point block) 'BFStreaming st'
MsgBatchDone, header
_:[header]
_) -> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$
BlockFetchProtocolFailure
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO BlockFetchProtocolFailure
BlockFetchProtocolFailureTooFewBlocks
(MsgBlock block1
_, []) -> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall (m :: * -> *) ps (pr :: PeerRole) (st :: ps) (stdone :: ps)
c.
m (PeerReceiver ps pr st stdone m c)
-> PeerReceiver ps pr st stdone m c
ReceiverEffect (m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
-> PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$
BlockFetchProtocolFailure
-> m (PeerReceiver
(BlockFetch block (Point block)) 'AsClient st' 'BFIdle m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO BlockFetchProtocolFailure
BlockFetchProtocolFailureTooManyBlocks
castRange :: (HeaderHash a ~ HeaderHash b)
=> ChainRange (Point a) -> ChainRange (Point b)
castRange :: forall a b.
(HeaderHash a ~ HeaderHash b) =>
ChainRange (Point a) -> ChainRange (Point b)
castRange (ChainRange Point a
l Point a
u) = Point b -> Point b -> ChainRange (Point b)
forall point. point -> point -> ChainRange point
ChainRange (Point a -> Point b
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point a
l) (Point a -> Point b
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point a
u)