View on GitHub
File Changes
    , ErrNetworkUnavailable (..)
    , NetworkLayer (..)
    , NextBlocksResult (..)
+
    , mapCursor
    )
import Codec.SerialiseTerm
    ( CodecCBORTerm )
    -- * Interface
      NetworkLayer (..)
    , NextBlocksResult (..)
+
    , mapCursor
    , Cursor
    , follow
    , FollowAction (..)
data NetworkLayer m target block = NetworkLayer
    { nextBlocks
        :: Cursor target
-
        -> ExceptT ErrGetBlock m (NextBlocksResult target block)
+
        -> ExceptT ErrGetBlock m (NextBlocksResult (Cursor target) block)
        -- ^ Starting from the given 'Cursor', fetches a contiguous sequence of
        -- blocks from the node, if they are available. An updated cursor will
        -- be returned with a 'RollFoward' result.

                      
-- | The result of 'nextBlocks', which is instructions for what the chain
-- consumer should do next.
-
data NextBlocksResult target block
+
data NextBlocksResult cursor block
    = AwaitReply
        -- ^ There are no blocks available from the node, so wait.
-
    | RollForward (Cursor target) BlockHeader [block]
+
    | RollForward cursor BlockHeader [block]
        -- ^ Apply the given contiguous non-empty sequence of blocks. Use the
        -- updated cursor to get the next batch. The given block header is the
        -- current tip of the node.
-
    | RollBackward (Cursor target)
+
    | RollBackward cursor
        -- ^ The chain consumer must roll back its state, then use the cursor to
        -- get the next batch of blocks.

                      
-
instance Functor (NextBlocksResult target) where
+
instance Functor (NextBlocksResult cursor) where
    fmap f = \case
        AwaitReply -> AwaitReply
        RollForward cur bh bs -> RollForward cur bh (fmap f bs)
        RollBackward cur -> RollBackward cur

                      
+
mapCursor :: (a -> b) -> NextBlocksResult a block -> NextBlocksResult b block
+
mapCursor fn = \case
+
    AwaitReply -> AwaitReply
+
    RollForward cur bh bs -> RollForward (fn cur) bh bs
+
    RollBackward cur -> RollBackward (fn cur)
+

                      
-- | @[email protected] enables the callback of @[email protected] to signal if the
-- chain-following should @[email protected], @[email protected], or if the current callback
-- should be forgotten and retried (@[email protected]).

                      
    _nextBlocks
        :: Cursor t
-
        -> ExceptT ErrGetBlock m (NextBlocksResult t block)
+
        -> ExceptT ErrGetBlock m (NextBlocksResult (Cursor t) block)
    _nextBlocks [email protected](Cursor localChain) = do
        lift (runExceptT _currentNodeTip) >>= \case
            Right _ -> do
        tryRollForward
            :: BlockHeader
            -> [block]
-
            -> NextBlocksResult t block
+
            -> NextBlocksResult (Cursor t) block
        tryRollForward tip = \case
            -- No more blocks to apply, no need to roll forward
            [] -> AwaitReply

                      
        rollBackward
            :: BlockHeader
-
            -> NextBlocksResult t block
+
            -> NextBlocksResult (Cursor t) block
        rollBackward point =
            RollBackward (cursorBackward point cursor)

                      
        recover
            :: BlockHeaders
-
            -> NextBlocksResult t block
+
            -> NextBlocksResult (Cursor t) block
        recover chain = case (blockHeadersBase chain, blockHeadersTip chain) of
            (Just baseH, Just tipH) | baseH /= tipH ->
                RollBackward (cursorBackward baseH cursor)
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
+
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
    , withNetworkLayer
    )
import Cardano.Wallet.Network
-
    ( ErrCurrentNodeTip (..)
+
    ( Cursor
+
    , ErrCurrentNodeTip (..)
    , ErrGetBlock (..)
    , NetworkLayer (..)
    , NextBlocksResult (..)
    let client = Jormungandr.mkJormungandrClient manager url
    runExceptT $ endpoint client resourceId

                      
-
instance Show (NextBlocksResult t b) where
+
instance Show (NextBlocksResult (Cursor t) b) where
    show AwaitReply = "AwaitReply"
    show (RollForward _ _ bs) = "RollForward " ++ show (length bs) ++ " blocks"
    show (RollBackward _) = "RollBackward"

                      
-
instance Eq (NextBlocksResult t b) where
+
instance Eq (NextBlocksResult (Cursor t) b) where
    a == b = show a == show b

                      
instance Arbitrary (Hash any) where
    arbitrary = Hash . BS.pack <$> vectorOf 32 arbitrary

                      
-
getRollForward :: NextBlocksResult target block -> Maybe [block]
+
getRollForward :: NextBlocksResult (Cursor t) block -> Maybe [block]
getRollForward AwaitReply = Nothing
getRollForward (RollForward _ _ bs) = Just bs
getRollForward (RollBackward _) = Nothing

                      
-
isRollForward :: NextBlocksResult target block -> Bool
+
isRollForward :: NextBlocksResult (Cursor t) block -> Bool
isRollForward = maybe False (not . null) . getRollForward

                      
isRollBackwardTo
-
    :: NetworkLayer m target block
+
    :: NetworkLayer m t block
    -> SlotId
-
    -> NextBlocksResult target block
+
    -> NextBlocksResult (Cursor t) block
    -> Bool
isRollBackwardTo nl sl = \case
    RollBackward cursor -> cursorSlotId nl cursor == sl