{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Ouroboros.Network.Protocol.ChainSync.ExamplesPipelined
( Client (..)
, chainSyncClientPipelinedMax
, chainSyncClientPipelinedMin
, chainSyncClientPipelinedLowHigh
) where
import Control.Concurrent.Class.MonadSTM.Strict
import Data.Word (Word16)
import Network.TypedProtocol.Core
import Ouroboros.Network.Block (BlockNo, HasHeader (..), Tip (..), blockNo,
getTipBlockNo)
import Ouroboros.Network.Mock.Chain (Chain (..), Point (..))
import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Point (WithOrigin (..))
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
import Ouroboros.Network.Protocol.ChainSync.Examples (Client (..))
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
chainSyncClientPipelined
:: forall header m a.
( HasHeader header
, MonadSTM m
)
=> MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelined :: forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelined MkPipelineDecision
mkPipelineDecision0 StrictTVar m (Chain header)
chainvar =
m (ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a)
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
ChainSyncClientPipelined (m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
-> ChainSyncClientPipelined header (Point header) (Tip header) m a)
-> (Client header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a))
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either
a ([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a)
-> m (Either
a ([Point header], Client header (Point header) (Tip header) m a))
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a)
-> (([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a)
-> Either
a ([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone ([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
initialise) (m (Either
a ([Point header], Client header (Point header) (Tip header) m a))
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a))
-> (Client header (Point header) (Tip header) m a
-> m (Either
a ([Point header], Client header (Point header) (Tip header) m a)))
-> Client header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Client header (Point header) (Tip header) m a
-> m (Either
a ([Point header], Client header (Point header) (Tip header) m a))
getChainPoints
where
initialise :: ([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle Z header (Point header) (Tip header) m a
initialise :: ([Point header], Client header (Point header) (Tip header) m a)
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
initialise ([Point header]
points, Client header (Point header) (Tip header) m a
client) =
[Point header]
-> ClientPipelinedStIntersect
header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall point header tip (m :: * -> *) a.
[point]
-> ClientPipelinedStIntersect header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
SendMsgFindIntersect [Point header]
points (ClientPipelinedStIntersect header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a)
-> ClientPipelinedStIntersect
header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a b. (a -> b) -> a -> b
$
ClientPipelinedStIntersect {
recvMsgIntersectFound :: Point header
-> Tip header
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
recvMsgIntersectFound = \Point header
_ Tip header
srvTip -> do
cliTipBlockNo <- Chain header -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
Chain.headBlockNo (Chain header -> WithOrigin BlockNo)
-> m (Chain header) -> m (WithOrigin BlockNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Chain header) -> m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Chain header)
chainvar
pure $ go mkPipelineDecision0 Zero cliTipBlockNo srvTip client,
recvMsgIntersectNotFound :: Tip header
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
recvMsgIntersectNotFound = \ Tip header
srvTip -> do
cliTipBlockNo <- Chain header -> WithOrigin BlockNo
forall block. HasHeader block => Chain block -> WithOrigin BlockNo
Chain.headBlockNo (Chain header -> WithOrigin BlockNo)
-> m (Chain header) -> m (WithOrigin BlockNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Chain header) -> m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Chain header)
chainvar
pure $ go mkPipelineDecision0 Zero cliTipBlockNo srvTip client
}
go :: MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go :: forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision Nat n
n WithOrigin BlockNo
cliTipBlockNo Tip header
srvTip client :: Client header (Point header) (Tip header) m a
client@Client {header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollforward :: header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollforward :: forall header point tip (m :: * -> *) t.
Client header point tip m t
-> header -> m (Either t (Client header point tip m t))
rollforward, Point header
-> Tip header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollbackward :: Point header
-> Tip header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollbackward :: forall header point tip (m :: * -> *) t.
Client header point tip m t
-> point -> tip -> m (Either t (Client header point tip m t))
rollbackward} =
let srvTipBlockNo :: WithOrigin BlockNo
srvTipBlockNo = Tip header -> WithOrigin BlockNo
forall {k} (b :: k). Tip b -> WithOrigin BlockNo
getTipBlockNo Tip header
srvTip in
case (Nat n
n, MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> (PipelineDecision n, MkPipelineDecision)
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> (PipelineDecision n, MkPipelineDecision)
runPipelineDecision MkPipelineDecision
mkPipelineDecision Nat n
n WithOrigin BlockNo
cliTipBlockNo WithOrigin BlockNo
srvTipBlockNo) of
(Nat n
_Zero, (PipelineDecision n
Request, MkPipelineDecision
mkPipelineDecision')) ->
m ()
-> ClientStNext 'Z header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall (m :: * -> *) header point tip a.
m ()
-> ClientStNext 'Z header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
SendMsgRequestNext
(() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
ClientStNext 'Z header (Point header) (Tip header) m a
clientStNext
where
clientStNext :: ClientStNext 'Z header (Point header) (Tip header) m a
clientStNext = ClientStNext {
recvMsgRollForward :: header
-> Tip header
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
recvMsgRollForward = \header
srvHeader Tip header
srvTip' -> do
header -> m ()
addBlock header
srvHeader
choice <- header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollforward header
srvHeader
pure $ case choice of
Left a
a -> a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat 'Z
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
Nat 'Z
n (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (header -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo header
srvHeader)) Tip header
srvTip' Client header (Point header) (Tip header) m a
client',
recvMsgRollBackward :: Point header
-> Tip header
-> m (ClientPipelinedStIdle
'Z header (Point header) (Tip header) m a)
recvMsgRollBackward = \Point header
pRollback Tip header
srvTip' -> do
cliTipBlockNo' <- Point header -> m (WithOrigin BlockNo)
rollback Point header
pRollback
choice <- rollbackward pRollback srvTip'
pure $ case choice of
Left a
a -> a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat 'Z
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
Nat 'Z
n WithOrigin BlockNo
cliTipBlockNo' Tip header
srvTip' Client header (Point header) (Tip header) m a
client'
}
(Nat n
_, (PipelineDecision n
Pipeline, MkPipelineDecision
mkPipelineDecision')) ->
m ()
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
SendMsgRequestNextPipelined
(() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(MkPipelineDecision
-> Nat ('S n)
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) WithOrigin BlockNo
cliTipBlockNo Tip header
srvTip Client header (Point header) (Tip header) m a
client)
(Succ Nat n
n', (PipelineDecision n
CollectOrPipeline, MkPipelineDecision
mkPipelineDecision')) ->
Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
-> ClientStNext n header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)
-> Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
forall a. a -> Maybe a
Just (m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)
-> Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)))
-> m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)
-> Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
forall a b. (a -> b) -> a -> b
$ ClientPipelinedStIdle ('S n) header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a)
forall a b. (a -> b) -> a -> b
$ m ()
-> ClientPipelinedStIdle
('S ('S n)) header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
forall (m :: * -> *) (n :: N) header point tip a.
m ()
-> ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
SendMsgRequestNextPipelined (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (MkPipelineDecision
-> Nat ('S ('S n))
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S ('S n)) header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' (Nat n -> Nat ('S ('S n))
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) WithOrigin BlockNo
cliTipBlockNo Tip header
srvTip Client header (Point header) (Tip header) m a
client))
ClientStNext {
recvMsgRollForward :: header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollForward = \header
srvHeader Tip header
srvTip' -> do
header -> m ()
addBlock header
srvHeader
choice <- header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollforward header
srvHeader
pure $ case choice of
Left a
a -> Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n' a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
n' (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (header -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo header
srvHeader)) Tip header
srvTip' Client header (Point header) (Tip header) m a
client',
recvMsgRollBackward :: Point header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollBackward = \Point header
pRollback Tip header
srvTip' -> do
cliTipBlockNo' <- Point header -> m (WithOrigin BlockNo)
rollback Point header
pRollback
choice <- rollbackward pRollback srvTip'
pure $ case choice of
Left a
a -> Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n' a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
n' WithOrigin BlockNo
cliTipBlockNo' Tip header
srvTip' Client header (Point header) (Tip header) m a
client'
}
(Succ Nat n
n', (PipelineDecision n
Collect, MkPipelineDecision
mkPipelineDecision')) ->
Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
-> ClientStNext n header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse
Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
forall a. Maybe a
Nothing
ClientStNext {
recvMsgRollForward :: header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollForward = \header
srvHeader Tip header
srvTip' -> do
header -> m ()
addBlock header
srvHeader
choice <- header
-> m (Either a (Client header (Point header) (Tip header) m a))
rollforward header
srvHeader
pure $ case choice of
Left a
a -> Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n' a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
n' (BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
At (header -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo header
srvHeader)) Tip header
srvTip' Client header (Point header) (Tip header) m a
client',
recvMsgRollBackward :: Point header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollBackward = \Point header
pRollback Tip header
srvTip' -> do
cliTipBlockNo' <- Point header -> m (WithOrigin BlockNo)
rollback Point header
pRollback
choice <- rollbackward pRollback srvTip'
pure $ case choice of
Left a
a -> Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n' a
a
Right Client header (Point header) (Tip header) m a
client' -> MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
MkPipelineDecision
-> Nat n
-> WithOrigin BlockNo
-> Tip header
-> Client header (Point header) (Tip header) m a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
go MkPipelineDecision
mkPipelineDecision' Nat n
n' WithOrigin BlockNo
cliTipBlockNo' Tip header
srvTip' Client header (Point header) (Tip header) m a
client'
}
collectAndDone :: Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone :: forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
Zero a
a = a
-> ClientPipelinedStIdle 'Z header (Point header) (Tip header) m a
forall a header point tip (m :: * -> *).
a -> ClientPipelinedStIdle 'Z header point tip m a
SendMsgDone a
a
collectAndDone (Succ Nat n
n) a
a = Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
-> ClientStNext n header (Point header) (Tip header) m a
-> ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a
forall (m :: * -> *) (n1 :: N) header point tip a.
Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m a))
-> ClientStNext n1 header point tip m a
-> ClientPipelinedStIdle ('S n1) header point tip m a
CollectResponse
Maybe
(m (ClientPipelinedStIdle
('S n) header (Point header) (Tip header) m a))
forall a. Maybe a
Nothing
ClientStNext {
recvMsgRollForward :: header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollForward = \header
_header Tip header
_point ->
ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a))
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
forall a b. (a -> b) -> a -> b
$ Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n a
a,
recvMsgRollBackward :: Point header
-> Tip header
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
recvMsgRollBackward = \Point header
_pRollback Tip header
_pHead ->
ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a))
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
-> m (ClientPipelinedStIdle
n header (Point header) (Tip header) m a)
forall a b. (a -> b) -> a -> b
$ Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
forall (n :: N).
Nat n
-> a
-> ClientPipelinedStIdle n header (Point header) (Tip header) m a
collectAndDone Nat n
n a
a
}
getChainPoints :: Client header (Point header) (Tip header) m a
-> m (Either a ([Point header], Client header (Point header) (Tip header) m a))
getChainPoints :: Client header (Point header) (Tip header) m a
-> m (Either
a ([Point header], Client header (Point header) (Tip header) m a))
getChainPoints Client header (Point header) (Tip header) m a
client = do
pts <- [Int] -> Chain header -> [Point header]
forall block.
HasHeader block =>
[Int] -> Chain block -> [Point block]
Chain.selectPoints [Int]
recentOffsets (Chain header -> [Point header])
-> m (Chain header) -> m [Point header]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Chain header) -> m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Chain header)
chainvar
choice <- points client pts
pure $ case choice of
Left a
a -> a
-> Either
a ([Point header], Client header (Point header) (Tip header) m a)
forall a b. a -> Either a b
Left a
a
Right Client header (Point header) (Tip header) m a
client' -> ([Point header], Client header (Point header) (Tip header) m a)
-> Either
a ([Point header], Client header (Point header) (Tip header) m a)
forall a b. b -> Either a b
Right ([Point header]
pts, Client header (Point header) (Tip header) m a
client')
addBlock :: header -> m ()
addBlock :: header -> m ()
addBlock header
b = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
chain <- StrictTVar m (Chain header) -> STM m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain header)
chainvar
let !chain' = header -> Chain header -> Chain header
forall block.
HasHeader block =>
block -> Chain block -> Chain block
Chain.addBlock header
b Chain header
chain
writeTVar chainvar chain'
rollback :: Point header -> m (WithOrigin BlockNo)
rollback :: Point header -> m (WithOrigin BlockNo)
rollback Point header
p = STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo))
-> STM m (WithOrigin BlockNo) -> m (WithOrigin BlockNo)
forall a b. (a -> b) -> a -> b
$ do
chain <- StrictTVar m (Chain header) -> STM m (Chain header)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Chain header)
chainvar
let (Just !chain') = Chain.rollback p chain
writeTVar chainvar chain'
pure $ Chain.headBlockNo chain'
recentOffsets :: [Int]
recentOffsets :: [Int]
recentOffsets = [Int
0,Int
1,Int
2,Int
3,Int
5,Int
8,Int
13,Int
21,Int
34,Int
55,Int
89,Int
144,Int
233,Int
377,Int
610,Int
987,Int
1597,Int
2584]
chainSyncClientPipelinedMax
:: forall header m a.
( HasHeader header
, MonadSTM m
)
=> Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedMax :: forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedMax Word16
omax = MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelined ((forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision
constantPipelineDecision ((forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision)
-> (forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision
forall a b. (a -> b) -> a -> b
$ Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
forall (n :: N).
Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMax Word16
omax)
chainSyncClientPipelinedMin
:: forall header m a.
( HasHeader header
, MonadSTM m
)
=> Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedMin :: forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedMin Word16
omax = MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelined ((forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision
constantPipelineDecision ((forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision)
-> (forall (n :: N).
Nat n
-> WithOrigin BlockNo -> WithOrigin BlockNo -> PipelineDecision n)
-> MkPipelineDecision
forall a b. (a -> b) -> a -> b
$ Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
forall (n :: N).
Word16
-> Nat n
-> WithOrigin BlockNo
-> WithOrigin BlockNo
-> PipelineDecision n
pipelineDecisionMin Word16
omax)
chainSyncClientPipelinedLowHigh
:: forall header m a.
( HasHeader header
, MonadSTM m
)
=> Word16
-> Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedLowHigh :: forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
Word16
-> Word16
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelinedLowHigh Word16
lowMark Word16
highMark = MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
forall header (m :: * -> *) a.
(HasHeader header, MonadSTM m) =>
MkPipelineDecision
-> StrictTVar m (Chain header)
-> Client header (Point header) (Tip header) m a
-> ChainSyncClientPipelined header (Point header) (Tip header) m a
chainSyncClientPipelined (Word16 -> Word16 -> MkPipelineDecision
pipelineDecisionLowHighMark Word16
lowMark Word16
highMark)