{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- |
-- Copyright: © 2020 IOHK
-- License: Apache-2.0
--
-- Ouroboros mini-protocols clients for implementing cardano-wallet. These
-- clients implement the logic and lift away concerns related to concrete
-- data-type representation so that the code can be re-used / shared between
-- Byron and Shelley.
module Ouroboros.Network.Client.Wallet
    (
      -- * ChainSyncFollowTip
      chainSyncFollowTip

      -- * ChainSyncWithBlocks
    , chainSyncWithBlocks
    , PipeliningStrategy(..)
    , thousandPipeliningStrategy
    , tunedForMainnetPipeliningStrategy

      -- * LocalTxSubmission
    , LocalTxSubmissionCmd (..)
    , localTxSubmission

      -- * LocalStateQuery
    , LSQ (..)
    , LocalStateQueryCmd (..)
    , localStateQuery

      -- * Helpers
    , send
    ) where

import Prelude

import Cardano.BM.Data.Tracer
    ( Tracer, traceWith )
import Cardano.Slotting.Slot
    ( WithOrigin (..) )
import Cardano.Wallet.Network
    ( ChainFollower (..), ChainSyncLog (..) )
import Control.Monad
    ( ap, liftM )
import Control.Monad.Class.MonadSTM
    ( MonadSTM
    , TQueue
    , atomically
    , newEmptyTMVarIO
    , peekTQueue
    , putTMVar
    , readTQueue
    , takeTMVar
    , tryReadTQueue
    , writeTQueue
    )
import Control.Monad.Class.MonadThrow
    ( Exception, MonadThrow, throwIO )
import Control.Monad.IO.Class
    ( MonadIO )
import Data.Functor
    ( (<&>) )
import Data.Kind
    ( Type )
import Data.List
    ( sortBy )
import Data.List.NonEmpty
    ( NonEmpty (..) )
import Data.Ord
    ( comparing )
import Data.Text
    ( Text )
import Data.Void
    ( Void )
import Network.TypedProtocol.Pipelined
    ( N (..), Nat (..), natToInt )
import Numeric.Natural
    ( Natural )
import Ouroboros.Consensus.HardFork.Combinator.Ledger.Query
    ( BlockQuery )
import Ouroboros.Consensus.Ledger.Query
    ( Query (..) )
import Ouroboros.Network.Block
    ( BlockNo (..)
    , HasHeader (..)
    , Point (..)
    , Tip (..)
    , blockNo
    , blockPoint
    , blockSlot
    , castTip
    , getTipPoint
    , pointSlot
    )
import Ouroboros.Network.Point
    ( blockPointSlot )
import Ouroboros.Network.Protocol.ChainSync.Client
    ( ChainSyncClient (..)
    , ClientStIdle (..)
    , ClientStIntersect (..)
    , ClientStNext (..)
    )
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
    ( ChainSyncClientPipelined (..) )
import Ouroboros.Network.Protocol.LocalStateQuery.Client
    ( ClientStAcquiring (..), LocalStateQueryClient (..) )
import Ouroboros.Network.Protocol.LocalTxSubmission.Client
    ( LocalTxClientStIdle (..), LocalTxSubmissionClient (..) )
import Ouroboros.Network.Protocol.LocalTxSubmission.Type
    ( SubmitResult (..) )

import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as P
import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ

--------------------------------------------------------------------------------
--
-- chainSyncFollowTip

-- | Client for the 'Chain Sync' mini-protocol, which provides notifications
-- when the node tip changes.
--
-- This is used in the same way as 'chainSyncWithBlocks', except that only one
-- of these clients is necessary, rather than one client per wallet.
chainSyncFollowTip
    :: forall m block era. (Monad m)
    => (block -> era)
    -> (Maybe era -> Tip block -> m ())
    -- ^ Callback for when the tip changes.
    -> ChainSyncClient block (Point block) (Tip block) m Void
chainSyncFollowTip :: (block -> era)
-> (Maybe era -> Tip block -> m ())
-> ChainSyncClient block (Point block) (Tip block) m Void
chainSyncFollowTip block -> era
toCardanoEra Maybe era -> Tip block -> m ()
onTipUpdate =
    m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (Bool -> m (ClientStIdle block (Point block) (Tip block) m Void)
clientStIdle Bool
False)
  where
    -- Client in the state 'Idle'. We immediately request the next block.
    clientStIdle
        :: Bool
        -> m (ClientStIdle block (Point block) (Tip block) m Void)
    clientStIdle :: Bool -> m (ClientStIdle block (Point block) (Tip block) m Void)
clientStIdle Bool
synced = ClientStIdle block (Point block) (Tip block) m Void
-> m (ClientStIdle block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle block (Point block) (Tip block) m Void
 -> m (ClientStIdle block (Point block) (Tip block) m Void))
-> ClientStIdle block (Point block) (Tip block) m Void
-> m (ClientStIdle block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ ClientStNext block (Point block) (Tip block) m Void
-> m (ClientStNext block (Point block) (Tip block) m Void)
-> ClientStIdle block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
ClientStNext header point tip m a
-> m (ClientStNext header point tip m a)
-> ClientStIdle header point tip m a
SendMsgRequestNext
        (Bool -> ClientStNext block (Point block) (Tip block) m Void
clientStNext Bool
synced)
        (ClientStNext block (Point block) (Tip block) m Void
-> m (ClientStNext block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStNext block (Point block) (Tip block) m Void
 -> m (ClientStNext block (Point block) (Tip block) m Void))
-> ClientStNext block (Point block) (Tip block) m Void
-> m (ClientStNext block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ Bool -> ClientStNext block (Point block) (Tip block) m Void
clientStNext Bool
synced)

    -- In the CanAwait state, we take the tip point given by the node and
    -- ask for the intersection of that point. This fast-fowards us to the
    -- tip. Once synchronised with the tip, we expect to be waiting for the
    -- server to send AwaitReply most of the time.
    clientStNext
        :: Bool
        -> ClientStNext block (Point block) (Tip block) m Void
    clientStNext :: Bool -> ClientStNext block (Point block) (Tip block) m Void
clientStNext Bool
False = ClientStNext :: forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
ClientStNext
            { recvMsgRollBackward :: Point block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgRollBackward = (Tip block
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> Point block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. a -> b -> a
const Tip block -> ChainSyncClient block (Point block) (Tip block) m Void
findIntersect
            , recvMsgRollForward :: block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgRollForward = (Tip block
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. a -> b -> a
const Tip block -> ChainSyncClient block (Point block) (Tip block) m Void
findIntersect
            }
      where
        findIntersect :: Tip block -> ChainSyncClient block (Point block) (Tip block) m Void
findIntersect Tip block
tip = m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle block (Point block) (Tip block) m Void)
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$
            ClientStIdle block (Point block) (Tip block) m Void
-> m (ClientStIdle block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle block (Point block) (Tip block) m Void
 -> m (ClientStIdle block (Point block) (Tip block) m Void))
-> ClientStIdle block (Point block) (Tip block) m Void
-> m (ClientStIdle block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ [Point block]
-> ClientStIntersect block (Point block) (Tip block) m Void
-> ClientStIdle block (Point block) (Tip block) m Void
forall point header tip (m :: * -> *) a.
[point]
-> ClientStIntersect header point tip m a
-> ClientStIdle header point tip m a
SendMsgFindIntersect [Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint (Tip block -> Point block) -> Tip block -> Point block
forall a b. (a -> b) -> a -> b
$ Tip block -> Tip block
forall a b. (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
castTip Tip block
tip] ClientStIntersect block (Point block) (Tip block) m Void
clientStIntersect

    -- On tip update, we'll also propagate the era inferred from blocks we
    -- received. In case of rollback, we only have a 'Point' and they are
    -- era-agnostic (for now at least!) which isn't a big deal really because
    -- the era will simply be updated on the next RollForward which follows
    -- immediately after.
    clientStNext Bool
True = ClientStNext :: forall header point tip (m :: * -> *) a.
(header -> tip -> ChainSyncClient header point tip m a)
-> (point -> tip -> ChainSyncClient header point tip m a)
-> ClientStNext header point tip m a
ClientStNext
            { recvMsgRollBackward :: Point block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgRollBackward = Maybe era
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
doUpdate (Maybe era
 -> Tip block
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> (Point block -> Maybe era)
-> Point block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe era -> Point block -> Maybe era
forall a b. a -> b -> a
const Maybe era
forall a. Maybe a
Nothing
            , recvMsgRollForward :: block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgRollForward  = Maybe era
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
doUpdate (Maybe era
 -> Tip block
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> (block -> Maybe era)
-> block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. era -> Maybe era
forall a. a -> Maybe a
Just (era -> Maybe era) -> (block -> era) -> block -> Maybe era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. block -> era
toCardanoEra
            }
      where
        doUpdate
            :: Maybe era
            -> Tip block
            -> ChainSyncClient block (Point block) (Tip block) m Void
        doUpdate :: Maybe era
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
doUpdate Maybe era
era Tip block
tip = m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle block (Point block) (Tip block) m Void)
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ do
            Maybe era -> Tip block -> m ()
onTipUpdate Maybe era
era (Tip block -> Tip block
forall a b. (HeaderHash a ~ HeaderHash b) => Tip a -> Tip b
castTip Tip block
tip)
            Bool -> m (ClientStIdle block (Point block) (Tip block) m Void)
clientStIdle Bool
True

    -- After an intersection is found, we return to idle with the sync flag
    -- set.
    clientStIntersect
        :: ClientStIntersect block (Point block) (Tip block) m Void
    clientStIntersect :: ClientStIntersect block (Point block) (Tip block) m Void
clientStIntersect = ClientStIntersect :: forall header point tip (m :: * -> *) a.
(point -> tip -> ChainSyncClient header point tip m a)
-> (tip -> ChainSyncClient header point tip m a)
-> ClientStIntersect header point tip m a
ClientStIntersect
        { recvMsgIntersectFound :: Point block
-> Tip block
-> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgIntersectFound = \Point block
_intersection Tip block
_tip ->
            m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle block (Point block) (Tip block) m Void)
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ Bool -> m (ClientStIdle block (Point block) (Tip block) m Void)
clientStIdle Bool
True
        , recvMsgIntersectNotFound :: Tip block -> ChainSyncClient block (Point block) (Tip block) m Void
recvMsgIntersectNotFound = \Tip block
_tip ->
            m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientStIdle header point tip m a)
-> ChainSyncClient header point tip m a
ChainSyncClient (m (ClientStIdle block (Point block) (Tip block) m Void)
 -> ChainSyncClient block (Point block) (Tip block) m Void)
-> m (ClientStIdle block (Point block) (Tip block) m Void)
-> ChainSyncClient block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ Bool -> m (ClientStIdle block (Point block) (Tip block) m Void)
clientStIdle Bool
False
        }

--------------------------------------------------------------------------------
--
-- chainSyncWithBlocks

-- | We interact with the 'NetworkClient' via a commands instrumenting the
-- client to move within the state-machine protocol. Commands are sent from a
-- parent thread via a shared 'TQueue'.
--
--
-- MAIN THREAD                   | NETWORK CLIENT THREAD
--                               |
--     *---------------*         |
--     |               |         |
--     | Wallet Engine |         |
--     |               |         |
--     *---------------*         |
--            |  ^               |
--            v  |               |
--     *---------------*         |        *----------------*
--     |               |         |        |                |
--     | Network Layer |<===[ TQueue ]===>| Network Client |
--     |               |         |        |                |
--     *---------------*         |        *----------------*
--                               |                |  ^
--                               |                v  |
--                               |     (ChainSync + TxSubmission)
--
-- The NetworkClient is idling most of the time and blocking on the TQueue while
-- waiting for commands. Upon receiving a command, it interprets it by sending
-- the corresponding instruction to the node and responding via a given
-- callback.
--
-- See also 'send' for invoking commands.

-- | A little type-alias to ease signatures in 'chainSyncWithBlocks'
type RequestNextStrategy m n block
    = P.ClientPipelinedStIdle n block (Point block) (Tip block) m Void

-- | How to drive pipelining size from the block height
data PipeliningStrategy block = PipeliningStrategy
    { PipeliningStrategy block -> block -> Natural
getPipeliningSize :: block -> Natural
    , PipeliningStrategy block -> Text
pipeliningStrategyName :: Text
    }

instance Show  (PipeliningStrategy block) where
    show :: PipeliningStrategy block -> String
show PipeliningStrategy{Text
pipeliningStrategyName :: Text
$sel:pipeliningStrategyName:PipeliningStrategy :: forall block. PipeliningStrategy block -> Text
pipeliningStrategyName}
        = Text -> String
T.unpack Text
pipeliningStrategyName

thousandPipeliningStrategy :: PipeliningStrategy block
thousandPipeliningStrategy :: PipeliningStrategy block
thousandPipeliningStrategy = PipeliningStrategy :: forall block.
(block -> Natural) -> Text -> PipeliningStrategy block
PipeliningStrategy {Text
block -> Natural
forall p p. Num p => p -> p
pipeliningStrategyName :: Text
getPipeliningSize :: forall p p. Num p => p -> p
$sel:pipeliningStrategyName:PipeliningStrategy :: Text
$sel:getPipeliningSize:PipeliningStrategy :: block -> Natural
..}
    where
        getPipeliningSize :: p -> p
getPipeliningSize p
_ = p
1_000
        pipeliningStrategyName :: Text
pipeliningStrategyName = Text
"Constant pipelining of 1000 blocks"

tunedForMainnetPipeliningStrategy :: HasHeader block => PipeliningStrategy block
tunedForMainnetPipeliningStrategy :: PipeliningStrategy block
tunedForMainnetPipeliningStrategy =  PipeliningStrategy :: forall block.
(block -> Natural) -> Text -> PipeliningStrategy block
PipeliningStrategy {Text
block -> Natural
forall b p. (HasHeader b, Num p) => b -> p
pipeliningStrategyName :: Text
getPipeliningSize :: forall b p. (HasHeader b, Num p) => b -> p
$sel:pipeliningStrategyName:PipeliningStrategy :: Text
$sel:getPipeliningSize:PipeliningStrategy :: block -> Natural
..}
    where
        getPipeliningSize :: b -> p
getPipeliningSize (b -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo -> BlockNo
n)
            | BlockNo
n BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockNo
5_200_000 = p
1000
            | BlockNo
n BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockNo
6_100_000 = p
200
            | BlockNo
n BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockNo
6_500_000 = p
125
            | Bool
otherwise      = p
100
        pipeliningStrategyName :: Text
pipeliningStrategyName = Text
"Variable pipelining suited for mainnet blockchain"

-- | Helper type for the different ways we handle rollbacks.
--
-- Helps remove some boilerplate.
data LocalRollbackResult block
    = Buffer [block]
    -- ^ The rollback could be handled by filtering the buffer. (The `[block]`
    -- corresponds to the new, filtered buffer.)
    | FollowerExact
    -- ^ `ChainFollower` was asked to rollback, and rolled back to the requested
    -- point exactly.
    | FollowerNeedToReNegotiate
    -- ^ The `ChainFollower` was asked to rollback, but rolled back further than
    -- requested. We must re-negotiate the intersection with the node.

-- | Client for the 'Chain Sync' mini-protocol.
--
-- Once started, the client simply runs ad-infinitum but one may
-- interact with it via a 'TQueue' of commands / messages used to move inside
-- the state-machine.
--
-- In a typical usage, 'chainSyncWithBlocks' would be executed in a forked
-- thread and given a 'TQueue' over which the parent thread as control.
--
-- >>> forkIO $ void $ chainSyncWithBlocks tr queue channel
-- ()
-- >>> writeTQueue queue ...
--
--                                    Agency
--     -------------------------------------------------------------------------
--     Client has agency*                | Idle
--     Server has agency*                | Intersect, Next
--
--     * A peer has agency if it is expected to send the next message.
--
--      *-----------*
--      | Intersect |◀══════════════════════════════╗
--      *-----------*         FindIntersect         ║
--            │                                     ║
--            │                                *---------*              *------*
--            │ Intersect.{Found,NotFound}     |         |═════════════▶| Done |
--            └───────────────────────────────╼|         |   MsgDone    *------*
--                                             |   Idle  |
--         ╔═══════════════════════════════════|         |
--         ║            RequestNext            |         |⇦ START
--         ║                                   *---------*
--         ▼                                        ╿
--      *------*       Roll.{Backward,Forward}      │
--      | Next |────────────────────────────────────┘
--      *------*
--
chainSyncWithBlocks
    :: forall m block. (Monad m, MonadSTM m, MonadThrow m, HasHeader block)
    => Tracer m (ChainSyncLog block (Point block))
    -> PipeliningStrategy block
    -> ChainFollower m (Point block) (Tip block) (NonEmpty block)
    -> ChainSyncClientPipelined block (Point block) (Tip block) m Void
chainSyncWithBlocks :: Tracer m (ChainSyncLog block (Point block))
-> PipeliningStrategy block
-> ChainFollower m (Point block) (Tip block) (NonEmpty block)
-> ChainSyncClientPipelined block (Point block) (Tip block) m Void
chainSyncWithBlocks Tracer m (ChainSyncLog block (Point block))
tr PipeliningStrategy block
pipeliningStrategy ChainFollower m (Point block) (Tip block) (NonEmpty block)
chainFollower =
    m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
-> ChainSyncClientPipelined block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
m (ClientPipelinedStIdle 'Z header point tip m a)
-> ChainSyncClientPipelined header point tip m a
ChainSyncClientPipelined m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateIntersection
  where
    -- Return the _number of slots between two tips.
    tipDistance :: BlockNo -> Tip block -> Natural
    tipDistance :: BlockNo -> Tip block -> Natural
tipDistance (BlockNo Word64
n) Tip block
TipGenesis =
        Natural
1 Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
    tipDistance (BlockNo Word64
n) (Tip SlotNo
_ HeaderHash block
_ (BlockNo Word64
n')) =
        forall b. (Integral Integer, Num b) => Integer -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer (Integer -> Natural) -> Integer -> Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => a -> a
abs (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n'

    -- | Keep only blocks from the list that are before or exactly at the given
    -- point.
    rollbackBuffer :: Point block -> [block] -> [block]
    rollbackBuffer :: Point block -> [block] -> [block]
rollbackBuffer Point block
pt = (block -> Bool) -> [block] -> [block]
forall a. (a -> Bool) -> [a] -> [a]
filter (\block
b -> SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At (block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot block
b) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= Point block -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point block
pt)

    clientStNegotiateIntersection
        :: m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
    clientStNegotiateIntersection :: m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateIntersection = do
        [Point block]
points <- ChainFollower m (Point block) (Tip block) (NonEmpty block)
-> m [Point block]
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> m [point]
readChainPoints ChainFollower m (Point block) (Tip block) (NonEmpty block)
chainFollower
        -- Cave: An empty list is interpreted as requesting the genesis point.
        let points' :: [Point block]
points' = if [Point block] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Point block]
points
                then [WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash block))
forall t. WithOrigin t
Origin]
                else (Point block -> Point block -> Ordering)
-> [Point block] -> [Point block]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Point block -> Point block -> Ordering)
-> Point block -> Point block -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Point block -> Point block -> Ordering
forall block. Point block -> Point block -> Ordering
compareSlot) [Point block]
points -- older points last
        Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ [Point block] -> ChainSyncLog block (Point block)
forall block point. [point] -> ChainSyncLog block point
MsgChainFindIntersect [Point block]
points'
        ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         'Z block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ [Point block]
-> ClientPipelinedStIntersect
     block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
forall point header tip (m :: * -> *) a.
[point]
-> ClientPipelinedStIntersect header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
P.SendMsgFindIntersect [Point block]
points' ClientPipelinedStIntersect block (Point block) (Tip block) m Void
clientStIntersect

    -- Receive the result of the MsgFindIntersection request
    clientStIntersect
        :: P.ClientPipelinedStIntersect block (Point block) (Tip block) m Void
    clientStIntersect :: ClientPipelinedStIntersect block (Point block) (Tip block) m Void
clientStIntersect = ClientPipelinedStIntersect :: forall header point tip (m :: * -> *) a.
(point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m a))
-> (tip -> m (ClientPipelinedStIdle 'Z header point tip m a))
-> ClientPipelinedStIntersect header point tip m a
P.ClientPipelinedStIntersect
        { recvMsgIntersectFound :: Point block
-> Tip block
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
P.recvMsgIntersectFound = \Point block
_point Tip block
tip -> do
            -- Here, the node tells us which  point  from the possible
            -- intersections is the latest point on the chain.
            -- However, we do not have to roll back to this point here;
            -- when we send a MsgRequestNext message, the node will reply
            -- with a MsgRollBackward message to this point first.
            --
            -- This behavior is not in the network specification yet, but see
            -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1623322238039900
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgChainTip (Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint Tip block
tip)
            ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
clientStIdle ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
oneByOne
        , recvMsgIntersectNotFound :: Tip block
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
P.recvMsgIntersectNotFound = \Tip block
_tip -> do
            -- No intersection was found.
            -- As the read-pointer on the node could be unknown to us,
            -- we now explicitly request the genesis point.
            --
            -- See also
            -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1634644689103100
            m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateGenesis
            }

    -- Explicitly negotiate the genesis point
    clientStNegotiateGenesis
        :: m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
    clientStNegotiateGenesis :: m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateGenesis = do
        let genesis :: [Point block]
genesis = [WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash block))
forall t. WithOrigin t
Origin]
        Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ [Point block] -> ChainSyncLog block (Point block)
forall block point. [point] -> ChainSyncLog block point
MsgChainFindIntersect [Point block]
forall block. [Point block]
genesis
        ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         'Z block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ [Point block]
-> ClientPipelinedStIntersect
     block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
forall point header tip (m :: * -> *) a.
[point]
-> ClientPipelinedStIntersect header point tip m a
-> ClientPipelinedStIdle 'Z header point tip m a
P.SendMsgFindIntersect [Point block]
forall block. [Point block]
genesis (ClientPipelinedStIntersect block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
-> ClientPipelinedStIntersect
     block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$
            ClientPipelinedStIntersect block (Point block) (Tip block) m Void
clientStIntersect
                { recvMsgIntersectNotFound :: Tip block
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
P.recvMsgIntersectNotFound = \Tip block
_tip ->
                    ErrChainSync
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ErrChainSync
ErrChainSyncNoIntersectGenesis
                }

    clientStIdle
        :: RequestNextStrategy m 'Z block
        -> m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
    clientStIdle :: ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
clientStIdle ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
strategy = ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
strategy

    -- Simple strategy that sends a request and waits for an answer.
    oneByOne :: RequestNextStrategy m 'Z block
    oneByOne :: ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
oneByOne = ClientStNext 'Z block (Point block) (Tip block) m Void
-> m (ClientStNext 'Z block (Point block) (Tip block) m Void)
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
forall header point tip (m :: * -> *) a.
ClientStNext 'Z header point tip m a
-> m (ClientStNext 'Z header point tip m a)
-> ClientPipelinedStIdle 'Z header point tip m a
P.SendMsgRequestNext
        ([block]
-> Nat 'Z -> ClientStNext 'Z block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [] Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero)
        (ClientStNext 'Z block (Point block) (Tip block) m Void
-> m (ClientStNext 'Z block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStNext 'Z block (Point block) (Tip block) m Void
 -> m (ClientStNext 'Z block (Point block) (Tip block) m Void))
-> ClientStNext 'Z block (Point block) (Tip block) m Void
-> m (ClientStNext 'Z block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ [block]
-> Nat 'Z -> ClientStNext 'Z block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [] Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero)

    -- We only pipeline requests when we are far from the tip. As soon as we
    -- reach the tip however, there's no point pipelining anymore, so we start
    -- collecting responses one by one.
    --
    --     0                                  tip
    --     |-----------------------------------|----->
    --                   pipelined               one by one
    pipeline
        :: Int
        -> Nat n
        -> RequestNextStrategy m n block
    pipeline :: Int -> Nat n -> RequestNextStrategy m n block
pipeline Int
goal (Succ Nat n
n) | Nat ('S n) -> Int
forall (n :: N). Nat n -> Int
natToInt (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
goal =
        Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
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
P.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
forall a. Maybe a
Nothing (ClientStNext n block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle
      ('S n) block (Point block) (Tip block) m Void)
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ [block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [] Nat n
n
    pipeline Int
goal Nat n
n =
        ClientPipelinedStIdle ('S n) block (Point block) (Tip block) m Void
-> RequestNextStrategy m n block
forall (n :: N) header point tip (m :: * -> *) a.
ClientPipelinedStIdle ('S n) header point tip m a
-> ClientPipelinedStIdle n header point tip m a
P.SendMsgRequestNextPipelined (ClientPipelinedStIdle
   ('S n) block (Point block) (Tip block) m Void
 -> RequestNextStrategy m n block)
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
-> RequestNextStrategy m n block
forall a b. (a -> b) -> a -> b
$ Int
-> Nat ('S n)
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall (n :: N). Int -> Nat n -> RequestNextStrategy m n block
pipeline Int
goal (Nat n -> Nat ('S n)
forall (m :: N) (n :: N). (m ~ 'S n) => Nat n -> Nat m
Succ Nat n
n)

    collectResponses
        :: [block]
        -> Nat n
        -> P.ClientStNext n block (Point block) (Tip block) m Void
    collectResponses :: [block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [block]
blocks Nat n
Zero = ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
P.ClientStNext
        { recvMsgRollForward :: block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollForward = \block
block Tip block
tip -> do
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgChainTip (Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint Tip block
tip)

            let blocks' :: NonEmpty block
blocks' = NonEmpty block -> NonEmpty block
forall a. NonEmpty a -> NonEmpty a
NE.reverse (block
block block -> [block] -> NonEmpty block
forall a. a -> [a] -> NonEmpty a
:| [block]
blocks)
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ NonEmpty block -> Point block -> ChainSyncLog block (Point block)
forall block point.
NonEmpty block -> point -> ChainSyncLog block point
MsgChainRollForward NonEmpty block
blocks' (Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint Tip block
tip)
            NonEmpty block -> Tip block -> m ()
handleRollforward NonEmpty block
blocks' Tip block
tip
            let distance :: Natural
distance = BlockNo -> Tip block -> Natural
tipDistance (block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo block
block) Tip block
tip
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Natural -> ChainSyncLog block (Point block)
forall block point. Natural -> ChainSyncLog block point
MsgTipDistance Natural
distance
            let strategy :: ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
strategy = if Natural
distance Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
1
                    then ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
oneByOne
                    else Int
-> Nat 'Z
-> ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
forall (n :: N). Int -> Nat n -> RequestNextStrategy m n block
pipeline
                        (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                            (Natural -> Int) -> (block -> Natural) -> block -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Natural -> Natural
forall a. Ord a => a -> a -> a
min Natural
distance
                            (Natural -> Natural) -> (block -> Natural) -> block -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PipeliningStrategy block -> block -> Natural
forall block. PipeliningStrategy block -> block -> Natural
getPipeliningSize PipeliningStrategy block
pipeliningStrategy
                            (block -> Int) -> block -> Int
forall a b. (a -> b) -> a -> b
$ block
block
                        )
                        Nat 'Z
forall (n :: N). ('Z ~ n) => Nat n
Zero
            ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
clientStIdle ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
strategy

        , recvMsgRollBackward :: Point block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollBackward = \Point block
point Tip block
tip -> do
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgChainTip (Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint Tip block
tip)
            LocalRollbackResult block
r <- [block]
-> Point block -> Tip block -> m (LocalRollbackResult block)
handleRollback [block]
blocks Point block
point Tip block
tip
            case LocalRollbackResult block
r of
                Buffer [block]
xs -> do
                    case [block] -> [block]
forall a. [a] -> [a]
reverse [block]
xs of
                        []          -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        (block
b:[block]
blocks') -> NonEmpty block -> Tip block -> m ()
handleRollforward (block
b block -> [block] -> NonEmpty block
forall a. a -> [a] -> NonEmpty a
:| [block]
blocks') Tip block
tip
                    ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
clientStIdle ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
oneByOne
                LocalRollbackResult block
FollowerExact ->
                    ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        'Z block (Point block) (Tip block) m Void)
clientStIdle ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void
oneByOne
                LocalRollbackResult block
FollowerNeedToReNegotiate ->
                    m (ClientPipelinedStIdle n block (Point block) (Tip block) m Void)
m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateIntersection
        }

    collectResponses [block]
blocks (Succ Nat n
n) = ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
P.ClientStNext
        { recvMsgRollForward :: block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollForward = \block
block Tip block
_tip ->
            ClientPipelinedStIdle ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   ('S n) block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         ('S n) block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
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
P.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
forall a. Maybe a
Nothing (ClientStNext n block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle
      ('S n) block (Point block) (Tip block) m Void)
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ [block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses (block
blockblock -> [block] -> [block]
forall a. a -> [a] -> [a]
:[block]
blocks) Nat n
n

        , recvMsgRollBackward :: Point block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollBackward = \Point block
point Tip block
tip -> do
            Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgChainTip (Tip block -> Point block
forall b. Tip b -> Point b
getTipPoint Tip block
tip)
            LocalRollbackResult block
r <- [block]
-> Point block -> Tip block -> m (LocalRollbackResult block)
handleRollback [block]
blocks Point block
point Tip block
tip
            ClientPipelinedStIdle ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   ('S n) block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         ('S n) block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
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
P.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
forall a. Maybe a
Nothing (ClientStNext n block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle
      ('S n) block (Point block) (Tip block) m Void)
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ case LocalRollbackResult block
r of
                Buffer [block]
xs -> [block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [block]
xs Nat n
n
                LocalRollbackResult block
FollowerExact -> [block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
[block]
-> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
collectResponses [] Nat n
n
                LocalRollbackResult block
FollowerNeedToReNegotiate -> Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
Nat n -> ClientStNext n block (Point block) (Tip block) m Void
dropResponsesAndRenegotiate Nat n
n
        }

    handleRollforward :: NonEmpty block -> Tip block -> m ()
    handleRollforward :: NonEmpty block -> Tip block -> m ()
handleRollforward NonEmpty block
blocks Tip block
tip = do
        ChainFollower m (Point block) (Tip block) (NonEmpty block)
-> NonEmpty block -> Tip block -> m ()
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> blocks -> tip -> m ()
rollForward ChainFollower m (Point block) (Tip block) (NonEmpty block)
chainFollower NonEmpty block
blocks Tip block
tip
        Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgLocalTip (block -> Point block
forall block. HasHeader block => block -> Point block
blockPoint (block -> Point block) -> block -> Point block
forall a b. (a -> b) -> a -> b
$ NonEmpty block -> block
forall a. NonEmpty a -> a
NE.last NonEmpty block
blocks)

    handleRollback
        :: [block]
        -> Point block
        -> Tip block
        -> m (LocalRollbackResult block)
    handleRollback :: [block]
-> Point block -> Tip block -> m (LocalRollbackResult block)
handleRollback [block]
buffer Point block
point Tip block
_tip = do
        let buffer' :: [block]
buffer' = Point block -> [block] -> [block]
rollbackBuffer Point block
point [block]
buffer
        Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> Int -> ChainSyncLog block (Point block)
forall block point. point -> Int -> ChainSyncLog block point
MsgChainRollBackward Point block
point ([block] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [block]
buffer')
        case [block]
buffer' of
            [] -> do
                Point block
actual <- ChainFollower m (Point block) (Tip block) (NonEmpty block)
-> Point block -> m (Point block)
forall (m :: * -> *) point tip blocks.
ChainFollower m point tip blocks -> point -> m point
rollBackward ChainFollower m (Point block) (Tip block) (NonEmpty block)
chainFollower Point block
point
                if Point block
actual Point block -> Point block -> Bool
forall a. Eq a => a -> a -> Bool
== Point block
point
                    then do
                        Tracer m (ChainSyncLog block (Point block))
-> ChainSyncLog block (Point block) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ChainSyncLog block (Point block))
tr (ChainSyncLog block (Point block) -> m ())
-> ChainSyncLog block (Point block) -> m ()
forall a b. (a -> b) -> a -> b
$ Point block -> ChainSyncLog block (Point block)
forall block point. point -> ChainSyncLog block point
MsgLocalTip Point block
point
                        LocalRollbackResult block -> m (LocalRollbackResult block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalRollbackResult block
forall block. LocalRollbackResult block
FollowerExact
                    else do
                        LocalRollbackResult block -> m (LocalRollbackResult block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalRollbackResult block
forall block. LocalRollbackResult block
FollowerNeedToReNegotiate
            [block]
xs -> do
                LocalRollbackResult block -> m (LocalRollbackResult block)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalRollbackResult block -> m (LocalRollbackResult block))
-> LocalRollbackResult block -> m (LocalRollbackResult block)
forall a b. (a -> b) -> a -> b
$ [block] -> LocalRollbackResult block
forall block. [block] -> LocalRollbackResult block
Buffer [block]
xs

    -- | Discards the in-flight requests, and re-negotiates the intersection
    -- afterwards.
    dropResponsesAndRenegotiate
        :: Nat n
        -> P.ClientStNext n block (Point block) (Tip block) m Void
    dropResponsesAndRenegotiate :: Nat n -> ClientStNext n block (Point block) (Tip block) m Void
dropResponsesAndRenegotiate (Succ Nat n
n) =
        ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
P.ClientStNext
            { recvMsgRollForward :: block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollForward = \block
_block Tip block
_tip ->
                ClientPipelinedStIdle ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   ('S n) block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         ('S n) block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
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
P.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
forall a. Maybe a
Nothing (ClientStNext n block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle
      ('S n) block (Point block) (Tip block) m Void)
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
Nat n -> ClientStNext n block (Point block) (Tip block) m Void
dropResponsesAndRenegotiate Nat n
n
            , recvMsgRollBackward :: Point block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollBackward = \Point block
_point Tip block
_tip ->
                ClientPipelinedStIdle ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientPipelinedStIdle
   ('S n) block (Point block) (Tip block) m Void
 -> m (ClientPipelinedStIdle
         ('S n) block (Point block) (Tip block) m Void))
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
-> m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void)
forall a b. (a -> b) -> a -> b
$ Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
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
P.CollectResponse Maybe
  (m (ClientPipelinedStIdle
        ('S n) block (Point block) (Tip block) m Void))
forall a. Maybe a
Nothing (ClientStNext n block (Point block) (Tip block) m Void
 -> ClientPipelinedStIdle
      ('S n) block (Point block) (Tip block) m Void)
-> ClientStNext n block (Point block) (Tip block) m Void
-> ClientPipelinedStIdle
     ('S n) block (Point block) (Tip block) m Void
forall a b. (a -> b) -> a -> b
$ Nat n -> ClientStNext n block (Point block) (Tip block) m Void
forall (n :: N).
Nat n -> ClientStNext n block (Point block) (Tip block) m Void
dropResponsesAndRenegotiate Nat n
n
            }
    dropResponsesAndRenegotiate Nat n
Zero =
        ClientStNext :: forall (n :: N) header point tip (m :: * -> *) a.
(header -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> (point
    -> tip -> m (ClientPipelinedStIdle n header point tip m a))
-> ClientStNext n header point tip m a
P.ClientStNext
            { recvMsgRollForward :: block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollForward = \block
_block Tip block
_tip ->
                m (ClientPipelinedStIdle n block (Point block) (Tip block) m Void)
m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateIntersection
            , recvMsgRollBackward :: Point block
-> Tip block
-> m (ClientPipelinedStIdle
        n block (Point block) (Tip block) m Void)
P.recvMsgRollBackward = \Point block
_point Tip block
_tip ->
                m (ClientPipelinedStIdle n block (Point block) (Tip block) m Void)
m (ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
clientStNegotiateIntersection
            }

compareSlot :: Point block -> Point block -> Ordering
compareSlot :: Point block -> Point block -> Ordering
compareSlot (Point WithOrigin (Block SlotNo (HeaderHash block))
Origin) (Point WithOrigin (Block SlotNo (HeaderHash block))
Origin) = Ordering
EQ
compareSlot (Point WithOrigin (Block SlotNo (HeaderHash block))
Origin) Point block
_ = Ordering
LT
compareSlot Point block
_ (Point WithOrigin (Block SlotNo (HeaderHash block))
Origin) = Ordering
GT
compareSlot (Point (At Block SlotNo (HeaderHash block)
b1)) (Point (At Block SlotNo (HeaderHash block)
b2)) = (Block SlotNo (HeaderHash block) -> SlotNo)
-> Block SlotNo (HeaderHash block)
-> Block SlotNo (HeaderHash block)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Block SlotNo (HeaderHash block) -> SlotNo
forall slot hash. Block slot hash -> slot
blockPointSlot Block SlotNo (HeaderHash block)
b1 Block SlotNo (HeaderHash block)
b2

--------------------------------------------------------------------------------
--
-- LocalStateQuery

-- | Type of commands that are stored in a queue for local state queries.
data LocalStateQueryCmd block m = forall a. SomeLSQ
    (LSQ block m a)
    (a -> m ())

-- | Client for the 'Local State Query' mini-protocol.
--
--                                    Agency
--     -------------------------------------------------------------------------
--     Client has agency*                | Idle, Acquired
--     Server has agency*                | Acquiring, Querying
--     * A peer has agency if it is expected to send the next message.
--
--                ┌───────────────┐    Done      ┌──────────┐
--        ┌──────▶│     Idle      ├─────────────▶│   Done   │
--        │       └───┬───────────┘              └──────────┘
--        │           │       ▲
--        │   Acquire │       │
--        │           │       │ Failure
--        │           ▼       │
--        │       ┌───────────┴───┐
--        │       │   Acquiring   │
--        │       └───┬───────────┘
-- Release│           │       ▲
--        │           │       │
--        │  Acquired │       │ ReAcquire
--        │           │       │
--        │           ▼       │
--        │       ┌───────────┴───┐   Query     ┌──────────┐
--        └───────┤   Acquired    ├────────────▶│ Querying │
--                │               │◀────────────┤          │
--                └───────────────┘     Result  └──────────┘
--
localStateQuery
    :: forall m block . (MonadIO m, MonadSTM m)
    => TQueue m (LocalStateQueryCmd block m)
        -- ^ We use a 'TQueue' as a communication channel to drive queries from
        -- outside of the network client to the client itself.
        -- Requests are pushed to the queue which are then transformed into
        -- messages to keep the state-machine moving.
    -> LocalStateQueryClient block (Point block) (Query block) m Void
localStateQuery :: TQueue m (LocalStateQueryCmd block m)
-> LocalStateQueryClient block (Point block) (Query block) m Void
localStateQuery TQueue m (LocalStateQueryCmd block m)
queue =
    m (ClientStIdle block (Point block) (Query block) m Void)
-> LocalStateQueryClient block (Point block) (Query block) m Void
forall block point (query :: * -> *) (m :: * -> *) a.
m (ClientStIdle block point query m a)
-> LocalStateQueryClient block point query m a
LocalStateQueryClient m (ClientStIdle block (Point block) (Query block) m Void)
clientStIdle
  where
    clientStIdle
        :: m (LSQ.ClientStIdle block (Point block) (Query block) m Void)
    clientStIdle :: m (ClientStIdle block (Point block) (Query block) m Void)
clientStIdle =
        Maybe (Point block)
-> ClientStAcquiring block (Point block) (Query block) m Void
-> ClientStIdle block (Point block) (Query block) m Void
forall point block (query :: * -> *) (m :: * -> *) a.
Maybe point
-> ClientStAcquiring block point query m a
-> ClientStIdle block point query m a
LSQ.SendMsgAcquire Maybe (Point block)
forall a. Maybe a
Nothing (ClientStAcquiring block (Point block) (Query block) m Void
 -> ClientStIdle block (Point block) (Query block) m Void)
-> (LocalStateQueryCmd block m
    -> ClientStAcquiring block (Point block) (Query block) m Void)
-> LocalStateQueryCmd block m
-> ClientStIdle block (Point block) (Query block) m Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalStateQueryCmd block m
-> ClientStAcquiring block (Point block) (Query block) m Void
clientStAcquiring (LocalStateQueryCmd block m
 -> ClientStIdle block (Point block) (Query block) m Void)
-> m (LocalStateQueryCmd block m)
-> m (ClientStIdle block (Point block) (Query block) m Void)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LocalStateQueryCmd block m)
awaitNextCmd

    clientStAcquiring
        :: LocalStateQueryCmd block m
        -> LSQ.ClientStAcquiring block (Point block) (Query block) m Void
    clientStAcquiring :: LocalStateQueryCmd block m
-> ClientStAcquiring block (Point block) (Query block) m Void
clientStAcquiring LocalStateQueryCmd block m
qry = ClientStAcquiring :: forall block point (query :: * -> *) (m :: * -> *) a.
m (ClientStAcquired block point query m a)
-> (AcquireFailure -> m (ClientStIdle block point query m a))
-> ClientStAcquiring block point query m a
LSQ.ClientStAcquiring
        { recvMsgAcquired :: m (ClientStAcquired block (Point block) (Query block) m Void)
recvMsgAcquired = LocalStateQueryCmd block m
-> m (ClientStAcquired block (Point block) (Query block) m Void)
clientStAcquired LocalStateQueryCmd block m
qry
        , recvMsgFailure :: AcquireFailure
-> m (ClientStIdle block (Point block) (Query block) m Void)
recvMsgFailure = \AcquireFailure
_failure -> do
            ClientStIdle block (Point block) (Query block) m Void
-> m (ClientStIdle block (Point block) (Query block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStIdle block (Point block) (Query block) m Void
 -> m (ClientStIdle block (Point block) (Query block) m Void))
-> ClientStIdle block (Point block) (Query block) m Void
-> m (ClientStIdle block (Point block) (Query block) m Void)
forall a b. (a -> b) -> a -> b
$ Maybe (Point block)
-> ClientStAcquiring block (Point block) (Query block) m Void
-> ClientStIdle block (Point block) (Query block) m Void
forall point block (query :: * -> *) (m :: * -> *) a.
Maybe point
-> ClientStAcquiring block point query m a
-> ClientStIdle block point query m a
LSQ.SendMsgAcquire Maybe (Point block)
forall a. Maybe a
Nothing (LocalStateQueryCmd block m
-> ClientStAcquiring block (Point block) (Query block) m Void
clientStAcquiring LocalStateQueryCmd block m
qry)
        }

    clientStAcquired
        :: LocalStateQueryCmd block m
        -> m (LSQ.ClientStAcquired block (Point block) (Query block) m Void)
    clientStAcquired :: LocalStateQueryCmd block m
-> m (ClientStAcquired block (Point block) (Query block) m Void)
clientStAcquired (SomeLSQ LSQ block m a
cmd a -> m ()
respond) = ClientStAcquired block (Point block) (Query block) m Void
-> m (ClientStAcquired block (Point block) (Query block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStAcquired block (Point block) (Query block) m Void
 -> m (ClientStAcquired block (Point block) (Query block) m Void))
-> ClientStAcquired block (Point block) (Query block) m Void
-> m (ClientStAcquired block (Point block) (Query block) m Void)
forall a b. (a -> b) -> a -> b
$ LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a.
LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
go LSQ block m a
cmd ((a -> ClientStAcquired block (Point block) (Query block) m Void)
 -> ClientStAcquired block (Point block) (Query block) m Void)
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a b. (a -> b) -> a -> b
$ \a
res ->
        -- We currently release the handle to the node state after
        -- each query in the queue. This allows the node to release
        -- resources (such as a stake distribution snapshot) after
        -- each query.
        --
        -- However, we /could/ read all LocalStateQueryCmds from the TQueue,
        -- and run them against the same tip, if re-acquiring takes a long time.
        -- As of Jan 2021, it seems like queries themselves take significantly
        -- longer than the acquiring.
        m (ClientStIdle block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall (m :: * -> *) block point (query :: * -> *) a.
m (ClientStIdle block point query m a)
-> ClientStAcquired block point query m a
LSQ.SendMsgRelease (m (ClientStIdle block (Point block) (Query block) m Void)
 -> ClientStAcquired block (Point block) (Query block) m Void)
-> m (ClientStIdle block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a b. (a -> b) -> a -> b
$ do
            -- In order to remove the query from the queue as soon as possible,
            -- @respond@ should return quickly and not throw any synchronous
            -- exception.
            -- In practice, we only use the 'send' helper here, so that works.
            --
            -- (Asynchronous exceptions are fine, as the connection to the node
            -- will not attempt to recover from that, and it doesn't matter
            -- whether a command is left in the queue or not.)
            a -> m ()
respond a
res
            m ()
finalizeCmd
            m (ClientStIdle block (Point block) (Query block) m Void)
clientStIdle
      where
          go
              :: forall a. LSQ block m a
              -> (a -> (LSQ.ClientStAcquired block (Point block) (Query block) m Void))
              -> (LSQ.ClientStAcquired block (Point block) (Query block) m Void)
          go :: LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
go (LSQPure a
a) a -> ClientStAcquired block (Point block) (Query block) m Void
cont = a -> ClientStAcquired block (Point block) (Query block) m Void
cont a
a
          go (LSQry BlockQuery block a
qry) a -> ClientStAcquired block (Point block) (Query block) m Void
cont = Query block a
-> ClientStQuerying block (Point block) (Query block) m Void a
-> ClientStAcquired block (Point block) (Query block) m Void
forall (query :: * -> *) result block point (m :: * -> *) a.
query result
-> ClientStQuerying block point query m a result
-> ClientStAcquired block point query m a
LSQ.SendMsgQuery (BlockQuery block a -> Query block a
forall blk result. BlockQuery blk result -> Query blk result
BlockQuery BlockQuery block a
qry)
            -- We only need to support queries of the type `BlockQuery`.
            (ClientStQuerying block (Point block) (Query block) m Void a
 -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStQuerying block (Point block) (Query block) m Void a
-> ClientStAcquired block (Point block) (Query block) m Void
forall a b. (a -> b) -> a -> b
$ (a
 -> m (ClientStAcquired block (Point block) (Query block) m Void))
-> ClientStQuerying block (Point block) (Query block) m Void a
forall block point (query :: * -> *) (m :: * -> *) a result.
(result -> m (ClientStAcquired block point query m a))
-> ClientStQuerying block point query m a result
LSQ.ClientStQuerying ((a
  -> m (ClientStAcquired block (Point block) (Query block) m Void))
 -> ClientStQuerying block (Point block) (Query block) m Void a)
-> (a
    -> m (ClientStAcquired block (Point block) (Query block) m Void))
-> ClientStQuerying block (Point block) (Query block) m Void a
forall a b. (a -> b) -> a -> b
$ \a
res -> do
                  ClientStAcquired block (Point block) (Query block) m Void
-> m (ClientStAcquired block (Point block) (Query block) m Void)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientStAcquired block (Point block) (Query block) m Void
 -> m (ClientStAcquired block (Point block) (Query block) m Void))
-> ClientStAcquired block (Point block) (Query block) m Void
-> m (ClientStAcquired block (Point block) (Query block) m Void)
forall a b. (a -> b) -> a -> b
$ a -> ClientStAcquired block (Point block) (Query block) m Void
cont a
res
                  -- It would be nice to trace the time it takes to run the
                  -- queries. We don't have a good opportunity to run IO after a
                  -- point is acquired, but before the query is send, however.
                  -- Heinrich: Actually, this can be done by adding a 'Tracer m'
                  -- to the scope and using it here. However, I believe that we
                  -- already have sufficiently good logging of execution times
                  -- in Cardano.Wallet.Shelley.Network .
          go (LSQBind LSQ block m a
ma a -> LSQ block m a
f) a -> ClientStAcquired block (Point block) (Query block) m Void
cont = LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a.
LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
go LSQ block m a
ma ((a -> ClientStAcquired block (Point block) (Query block) m Void)
 -> ClientStAcquired block (Point block) (Query block) m Void)
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a b. (a -> b) -> a -> b
$ \a
a -> do
              LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a.
LSQ block m a
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
go (a -> LSQ block m a
f a
a) ((a -> ClientStAcquired block (Point block) (Query block) m Void)
 -> ClientStAcquired block (Point block) (Query block) m Void)
-> (a -> ClientStAcquired block (Point block) (Query block) m Void)
-> ClientStAcquired block (Point block) (Query block) m Void
forall a b. (a -> b) -> a -> b
$ \a
b -> a -> ClientStAcquired block (Point block) (Query block) m Void
cont a
b

    -- | Note that we for LSQ and TxSubmission use peekTQueue when starting the
    -- request, and only remove the command from the queue after we have
    -- processed the response from the node.
    --
    -- If the connection to the node drops, this makes cancelled commands
    -- automatically retry on reconnection.
    --
    -- IMPORTANT: callers must also `finalizeCmd`, because of the above.
    awaitNextCmd :: m (LocalStateQueryCmd block m)
    awaitNextCmd :: m (LocalStateQueryCmd block m)
awaitNextCmd = STM m (LocalStateQueryCmd block m)
-> m (LocalStateQueryCmd block m)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LocalStateQueryCmd block m)
 -> m (LocalStateQueryCmd block m))
-> STM m (LocalStateQueryCmd block m)
-> m (LocalStateQueryCmd block m)
forall a b. (a -> b) -> a -> b
$ TQueue m (LocalStateQueryCmd block m)
-> STM m (LocalStateQueryCmd block m)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
peekTQueue TQueue m (LocalStateQueryCmd block m)
queue

    finalizeCmd :: m ()
    finalizeCmd :: m ()
finalizeCmd = STM m () -> m ()
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
$ TQueue m (LocalStateQueryCmd block m)
-> STM m (Maybe (LocalStateQueryCmd block m))
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m (Maybe a)
tryReadTQueue TQueue m (LocalStateQueryCmd block m)
queue STM m (Maybe (LocalStateQueryCmd block m))
-> (Maybe (LocalStateQueryCmd block m) -> STM m ()) -> STM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just LocalStateQueryCmd block m
_ -> () -> STM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe (LocalStateQueryCmd block m)
Nothing -> String -> STM m ()
forall a. HasCallStack => String -> a
error String
"finalizeCmd: queue is not empty"

-- | Monad for composing local state queries for the node /tip/.
--
-- /Warning/: Partial functions inside the @LSQ@ monad may cause the entire
-- wallet to crash when interpreted by @localStateQuery@.
data LSQ block (m :: Type -> Type) a where
    LSQPure :: a -> LSQ block m a
    LSQBind :: LSQ block m a -> (a -> LSQ block m b) -> LSQ block m b

    -- | A local state query.
    LSQry :: (BlockQuery block res) -> LSQ block m res

instance Functor (LSQ block m) where
    fmap :: (a -> b) -> LSQ block m a -> LSQ block m b
fmap = (a -> b) -> LSQ block m a -> LSQ block m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative (LSQ block m) where
    pure :: a -> LSQ block m a
pure  = a -> LSQ block m a
forall a block (m :: * -> *). a -> LSQ block m a
LSQPure
    <*> :: LSQ block m (a -> b) -> LSQ block m a -> LSQ block m b
(<*>) = LSQ block m (a -> b) -> LSQ block m a -> LSQ block m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (LSQ block m) where
    return :: a -> LSQ block m a
return = a -> LSQ block m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    >>= :: LSQ block m a -> (a -> LSQ block m b) -> LSQ block m b
(>>=)  = LSQ block m a -> (a -> LSQ block m b) -> LSQ block m b
forall block (m :: * -> *) a b.
LSQ block m a -> (a -> LSQ block m b) -> LSQ block m b
LSQBind

--------------------------------------------------------------------------------
--
-- LocalTxSubmission


-- | Type of commands that are stored in a queue for localTxSubmission.
data LocalTxSubmissionCmd tx err (m :: Type -> Type)
    = CmdSubmitTx tx (SubmitResult err -> m ())

-- | Client for the 'Local Tx Submission' mini-protocol.
--
--                                    Agency
--     -------------------------------------------------------------------------
--     Client has agency*                | Idle
--     Server has agency*                | Busy
--     * A peer has agency if it is expected to send the next message.
--
--      *-----------*
--      |    Busy   |◀══════════════════════════════╗
--      *-----------*            SubmitTx           ║
--         │     │                                  ║
--         │     │                             *---------*              *------*
--         │     │        AcceptTx             |         |═════════════▶| Done |
--         │     └────────────────────────────╼|         |   MsgDone    *------*
--         │              RejectTx             |   Idle  |
--         └──────────────────────────────────╼|         |
--                                             |         |⇦ START
--                                             *---------*
localTxSubmission
    :: forall m tx err. (MonadThrow m, MonadSTM m)
    => TQueue m (LocalTxSubmissionCmd tx err m)
        -- ^ We use a 'TQueue' as a communication channel to drive queries from
        -- outside of the network client to the client itself.
        -- Requests are pushed to the queue which are then transformed into
        -- messages to keep the state-machine moving.
    -> LocalTxSubmissionClient tx err m ()
localTxSubmission :: TQueue m (LocalTxSubmissionCmd tx err m)
-> LocalTxSubmissionClient tx err m ()
localTxSubmission TQueue m (LocalTxSubmissionCmd tx err m)
queue = m (LocalTxClientStIdle tx err m ())
-> LocalTxSubmissionClient tx err m ()
forall tx reject (m :: * -> *) a.
m (LocalTxClientStIdle tx reject m a)
-> LocalTxSubmissionClient tx reject m a
LocalTxSubmissionClient m (LocalTxClientStIdle tx err m ())
clientStIdle
  where
    clientStIdle
        :: m (LocalTxClientStIdle tx err m ())
    clientStIdle :: m (LocalTxClientStIdle tx err m ())
clientStIdle = STM m (LocalTxSubmissionCmd tx err m)
-> m (LocalTxSubmissionCmd tx err m)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue m (LocalTxSubmissionCmd tx err m)
-> STM m (LocalTxSubmissionCmd tx err m)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
peekTQueue TQueue m (LocalTxSubmissionCmd tx err m)
queue) m (LocalTxSubmissionCmd tx err m)
-> (LocalTxSubmissionCmd tx err m
    -> LocalTxClientStIdle tx err m ())
-> m (LocalTxClientStIdle tx err m ())
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        CmdSubmitTx tx
tx SubmitResult err -> m ()
respond ->
            tx
-> (SubmitResult err -> m (LocalTxClientStIdle tx err m ()))
-> LocalTxClientStIdle tx err m ()
forall tx reject (m :: * -> *) a.
tx
-> (SubmitResult reject -> m (LocalTxClientStIdle tx reject m a))
-> LocalTxClientStIdle tx reject m a
SendMsgSubmitTx tx
tx ((SubmitResult err -> m (LocalTxClientStIdle tx err m ()))
 -> LocalTxClientStIdle tx err m ())
-> (SubmitResult err -> m (LocalTxClientStIdle tx err m ()))
-> LocalTxClientStIdle tx err m ()
forall a b. (a -> b) -> a -> b
$ \SubmitResult err
res -> do
                SubmitResult err -> m ()
respond SubmitResult err
res
                -- Same note about peekTQueue from `localStateQuery` applies
                -- here.
                LocalTxSubmissionCmd tx err m
_processedCmd <- STM m (LocalTxSubmissionCmd tx err m)
-> m (LocalTxSubmissionCmd tx err m)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TQueue m (LocalTxSubmissionCmd tx err m)
-> STM m (LocalTxSubmissionCmd tx err m)
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> STM m a
readTQueue TQueue m (LocalTxSubmissionCmd tx err m)
queue)
                m (LocalTxClientStIdle tx err m ())
clientStIdle

{-------------------------------------------------------------------------------
    Helpers
-------------------------------------------------------------------------------}

-- | Helper function to send commands to the node via a 'TQueue'
-- and receive results.
--
-- One of the main purposes of this functions is to handle an existentially
-- quantified type.
-- In typical use, the @cmd m@ involves existential quantification over
-- the type @a@, so that the 'TQueue' has elements with a monomorphic type.
-- However, the type signature of `send` allows us to retrieve this particular
-- type @a@ for later use again.
send
    :: MonadSTM m
    => TQueue m (cmd m)
    -> ((a -> m ()) -> cmd m)
    -> m a
send :: TQueue m (cmd m) -> ((a -> m ()) -> cmd m) -> m a
send TQueue m (cmd m)
queue (a -> m ()) -> cmd m
cmd = do
    TMVar m a
tvar <- m (TMVar m a)
forall (m :: * -> *) a. MonadSTM m => m (TMVar m a)
newEmptyTMVarIO
    STM m () -> m ()
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
$ TQueue m (cmd m) -> cmd m -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m (cmd m)
queue ((a -> m ()) -> cmd m
cmd (STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (a -> STM m ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> a -> STM m ()
putTMVar TMVar m a
tvar))
    STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar m a
tvar

{-------------------------------------------------------------------------------
    Errors
-------------------------------------------------------------------------------}
data ErrChainSync
    = ErrChainSyncNoIntersectGenesis
    -- ^ The node does not give us genesis when we request it with a
    -- 'MsgFindIntersect' message in the ChainSync protocol.
    -- This should not happen.
    deriving (ErrChainSync -> ErrChainSync -> Bool
(ErrChainSync -> ErrChainSync -> Bool)
-> (ErrChainSync -> ErrChainSync -> Bool) -> Eq ErrChainSync
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrChainSync -> ErrChainSync -> Bool
$c/= :: ErrChainSync -> ErrChainSync -> Bool
== :: ErrChainSync -> ErrChainSync -> Bool
$c== :: ErrChainSync -> ErrChainSync -> Bool
Eq, Int -> ErrChainSync -> ShowS
[ErrChainSync] -> ShowS
ErrChainSync -> String
(Int -> ErrChainSync -> ShowS)
-> (ErrChainSync -> String)
-> ([ErrChainSync] -> ShowS)
-> Show ErrChainSync
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrChainSync] -> ShowS
$cshowList :: [ErrChainSync] -> ShowS
show :: ErrChainSync -> String
$cshow :: ErrChainSync -> String
showsPrec :: Int -> ErrChainSync -> ShowS
$cshowsPrec :: Int -> ErrChainSync -> ShowS
Show)

instance Exception ErrChainSync