{-# 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

-- | Pipelined chain sync client which pipelines at most @omax@ requests according to 'MkPipelineDecision' policy.
--
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
$
      -- In this consumer example, we do not care about whether the server
      -- found an intersection or not. If not, we'll just sync from genesis.
      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
      }

    -- Drive pipelining by using @mkPipelineDecision@ callback.
    go :: MkPipelineDecision
       -> Nat n
       -> WithOrigin BlockNo
       -- ^ our head
       -> Tip header
       -- ^ head of the server
       -> 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
              -- We have the opportunity to do something when receiving
              -- MsgAwaitReply. In this example we don't take up that opportunity.
              (() -> 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 ())   -- ignore MsgAwaitReply
            (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
            -- if there is no message we pipeline next one; it is important we
            -- do not directly loop here, but send something; otherwise we
            -- would just build a busy loop polling the driver's receiving
            -- queue.
            (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'
              }


    -- Recursively collect all outstanding responses, but do nothing with them.
    -- If 'CollectResponse' returns an error when applying
    -- roll forward or roll backward instruction, we collect all the
    -- outstanding responses and send 'MsgDone'.
    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
        --TODO: handle rollback failure
        let (Just !chain') = Chain.rollback p chain
        writeTVar chainvar chain'
        pure $ Chain.headBlockNo chain'

-- | Offsets from the head of the chain to select points on the consumer's
-- chain to send to the producer. The specific choice here is fibonacci up
-- to 2160.
--
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]


-- | A pipelined chain-sync client that sends eagerly up @omax@ pipelined
-- request and then collects all responses and starts over again.  This
-- presents maximum pipelining and presents minimum choice to the environment
-- (drivers).
--
-- This client is only useful in tests and reference implementation: it is
-- using mock representation of a chain.
--
-- If @omax@ is equal to 3 the communication will look like (if the client is
-- far from server's tip;  pipelining is presented with long pauses to
-- ilustrate when messages will be collected).
--
-- >
-- >'MsgFindIntersect' ↘ │ ╲    │
-- >                     │  ╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgIntersectFound' or 'MsgIntersectNotFound'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >                     │  ╱   │
-- >  'MsgRequestNext' ↘ │ ╱    │
-- >                     │ ╲    │
-- >                     │  ╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >  'MsgRequestNext' ↘ │   ╱  │
-- >                     │ ╲╱   │
-- >                     │ ╱╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >  'MsgRequestNext' ↘ │ ╲╱   │
-- >                     │ ╱╲   │
-- >         'Collect' ↙ │╱  ╲  │
-- >  'MsgRequestNext' ↘ │╲     │
-- >                     ┆      ┆
-- >
-- >                     ┆      ┆
-- >         'Collect' ↙ │╱  ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >                     │  ╱   │
-- >         'Collect' ↙ │ ╱    │
-- >                     │      │
-- >
--
chainSyncClientPipelinedMax
      :: forall header m a.
         ( HasHeader header
         , MonadSTM m
         )
      => Word16
      -- ^ maximal number of outstanding requests
      -> 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)

-- | A pipelined chain-sycn client that pipelines at most @omax@ requests and
-- always tries to collect any replies as soon as they are available.   This
-- keeps pipelining to bare minimum, and gives maximum choice to the
-- environment (drivers).
--
-- If @omax@ is equal to 3 the communication will look like (if the client is
-- far from server's tip;  pipelining is presented with long pauses to
-- ilustrate when messages will be collected).
--
-- >
-- >'MsgFindIntersect' ↘ │ ╲    │
-- >                     │  ╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgIntersectFound' or 'MsgIntersectNotFound'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >                     │  ╱   │
-- >  'MsgRequestNext' ↘ │ ╱    │
-- >                     │ ╲    │
-- >                     │  ╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >  'MsgRequestNext' ↘ │   ╱  │
-- >                     │ ╲╱   │
-- >         'Collect' ↙ │ ╱╲   │
-- >                     │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >  'MsgRequestNext' ↘ │ ╲╱   │
-- >                     │ ╱╲   │
-- >         'Collect' ↙ │   ╲  │
-- >                     │    ╲ │ ↙ 'MsgRollForward' or 'MsgRollBackward'
-- >                     │    ╱ │
-- >                     │   ╱  │
-- >                     │  ╱   │
-- >         'Collect' ↙ │ ╱    │
-- >                     │      │
-- >
--
chainSyncClientPipelinedMin
      :: forall header m a.
         ( HasHeader header
         , MonadSTM m
         )
      => Word16
      -- ^ maximal number of outstanding requests
      -> 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
      -- ^ low mark
      -> Word16
      -- ^ high mark
      -> 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)