Add nextBlocks function

cardano-wallet.cabal

@@ -42,8 +42,10 @@ library
     , digest
     , fmt
     , http-api-data
+    , http-client
     , http-media
     , memory
+    , mtl
     , servant
     , servant-client
     , text
@@ -52,14 +54,18 @@ library
   hs-source-dirs:
       src
   exposed-modules:
+      Cardano.ChainProducer
+      Cardano.ChainProducer.RustHttpBridge
       Cardano.ChainProducer.RustHttpBridge.Api
       Cardano.ChainProducer.RustHttpBridge.Client
-      Cardano.Wallet.BlockSyncer
-      Servant.Extra.ContentTypes
+      Cardano.ChainProducer.RustHttpBridge.NetworkLayer
       Cardano.Wallet
       Cardano.Wallet.Binary
       Cardano.Wallet.Binary.Packfile
+      Cardano.Wallet.BlockSyncer
       Cardano.Wallet.Primitive
+      Cardano.Wallet.Slotting
+      Servant.Extra.ContentTypes
   other-modules:
       Paths_cardano_wallet
 
@@ -102,8 +108,11 @@ test-suite unit
     , cborg
     , containers
     , deepseq
+    , exceptions
     , hspec
+    , hspec-expectations
     , memory
+    , mtl
     , QuickCheck
     , time-units
     , transformers
@@ -116,6 +125,10 @@ test-suite unit
   other-modules:
       Cardano.WalletSpec
       Cardano.Wallet.BinarySpec
+      Cardano.ChainProducer.RustHttpBridge.MockNetworkLayer
+      Cardano.ChainProducer.RustHttpBridgeSpec
       Cardano.Wallet.Binary.PackfileSpec
-      Cardano.Wallet.PrimitiveSpec
       Cardano.Wallet.BlockSyncerSpec
+      Cardano.Wallet.PrimitiveSpec
+      Cardano.Wallet.SlottingOrphans
+      Cardano.Wallet.SlottingSpec

src/Cardano/ChainProducer.hs

@@ -0,0 +1,32 @@
+module Cardano.ChainProducer
+    ( MonadChainProducer (..)
+    , ErrGetNextBlocks (..)
+    ) where
+
+import Prelude
+
+import Cardano.Wallet.Primitive
+    ( Block )
+import Cardano.Wallet.Slotting
+    ( SlotCount, SlotId )
+import Control.Exception
+    ( Exception )
+import Control.Monad.Except
+    ( ExceptT )
+
+class MonadChainProducer m where
+    -- | Get some blocks from the chain producer.
+    --
+    -- This may retrieve less than the requested number of blocks.
+    -- It might return no blocks at all.
+    nextBlocks
+        :: SlotCount -- ^ Number of blocks to retrieve
+        -> SlotId    -- ^ Starting point
+        -> ExceptT ErrGetNextBlocks m [Block]
+
+-- | The things that can go wrong when retrieving blocks.
+newtype ErrGetNextBlocks
+    = GetNextBlocksError String
+    deriving (Show, Eq)
+
+instance Exception ErrGetNextBlocks

src/Cardano/ChainProducer/RustHttpBridge.hs

@@ -0,0 +1,188 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.ChainProducer.RustHttpBridge
+    ( RustBackend
+    , runRustBackend
+    ) where
+
+import Control.Monad.Except
+    ( ExceptT (..), mapExceptT, runExceptT )
+import Control.Monad.IO.Class
+    ( MonadIO, liftIO )
+import Control.Monad.Reader
+    ( MonadReader, ReaderT (..), ask, lift )
+import Data.Bifunctor
+    ( first )
+import Data.Maybe
+    ( fromMaybe )
+import Prelude
+
+import Cardano.ChainProducer
+    ( ErrGetNextBlocks (..), MonadChainProducer (..) )
+import Cardano.ChainProducer.RustHttpBridge.NetworkLayer
+    ( NetworkLayer (..), NetworkLayerError )
+import Cardano.Wallet.Primitive
+    ( Block (..), BlockHeader (..), Hash (..) )
+import Cardano.Wallet.Slotting
+    ( EpochIndex
+    , LocalSlotIndex (..)
+    , SlotCount
+    , SlotId (..)
+    , addSlots
+    , slotNext
+    , slotsPerEpoch
+    )
+
+newtype RustBackend a = RustBackend {
+    runRB :: ReaderT (NetworkLayer IO) IO a
+    } deriving (Monad, Applicative, Functor,
+                MonadReader (NetworkLayer IO), MonadIO)
+
+runRustBackend :: NetworkLayer IO -> RustBackend a -> IO a
+runRustBackend network action = runReaderT (runRB action) network
+
+getNetwork :: RustBackend (NetworkLayer IO)
+getNetwork = ask
+
+instance MonadChainProducer RustBackend where
+    nextBlocks = rbNextBlocks
+
+-- Note: This will be quite inefficient for at least two reasons.
+-- 1. If the number of blocks requested is small, it will fetch the same epoch
+--    pack file repeatedly.
+-- 2. Fetching the tip block and working backwards is not ideal.
+-- We will keep it for now, and it can be improved later.
+rbNextBlocks
+    :: SlotCount -- ^ Number of blocks to retrieve
+    -> SlotId    -- ^ Starting point
+    -> ExceptT ErrGetNextBlocks RustBackend [Block]
+rbNextBlocks numBlocks start = do
+    net <- lift getNetwork
+    (tipHash, tip) <- fmap headerSlot <$> runNetworkLayer (getNetworkTip net)
+    epochBlocks <- blocksFromPacks net tip
+    lastBlocks <- unstableBlocks net tipHash tip epochBlocks
+    pure (epochBlocks ++ lastBlocks)
+
+    where
+        end = addSlots numBlocks start
+
+        -- Grab blocks from epoch pack files
+        blocksFromPacks network tip = do
+            let epochs = epochRange numBlocks start tip
+            epochBlocks <- runNetworkLayer (getEpochs network epochs)
+            pure $ filter (blockIsBetween start end) (concat epochBlocks)
+
+        -- The next slot after the last block.
+        slotAfter [] = Nothing
+        slotAfter bs = Just . slotNext . headerSlot . header . last $ bs
+
+        -- Grab the remaining blocks which aren't packed in epoch files,
+        -- starting from the tip.
+        unstableBlocks network tipHash tip epochBlocks = do
+            let start' = fromMaybe start (slotAfter epochBlocks)
+
+            lastBlocks <- if end > start' && start' <= tip
+                then runNetworkLayer $ fetchBlocksFromTip network start' tipHash
+                else pure []
+
+            pure $ filter (blockIsBefore end) lastBlocks
+
+-- | Fetch epoch blocks until one fails.
+getEpochs
+    :: Monad m
+    => NetworkLayer m
+    -> [EpochIndex]
+    -> ExceptT NetworkLayerError m [[Block]]
+getEpochs network = mapUntilError (getEpoch network)
+
+-- Fetch blocks which are not in epoch pack files.
+fetchBlocksFromTip
+    :: Monad m
+    => NetworkLayer m
+    -> SlotId
+    -> Hash "BlockHeader"
+    -> ExceptT NetworkLayerError m [Block]
+fetchBlocksFromTip network start tipHash = reverse <$> workBackwards tipHash
+    where
+        workBackwards headerHash = do
+            block <- getBlock network headerHash
+            if blockIsAfter start block
+                then do
+                    blocks <- workBackwards $ prevBlockHash $ header block
+                    pure (block:blocks)
+                else pure [block]
+
+runNetworkLayer
+    :: ExceptT NetworkLayerError IO a
+    -> ExceptT ErrGetNextBlocks RustBackend a
+runNetworkLayer = mapExceptT (fmap handle . liftIO)
+    where
+        handle = first (GetNextBlocksError . show)
+
+-- * Utility functions for monadic loops
+
+-- | Apply an action to each element of a list, until an action fails, or there
+-- are no more elements. This is like mapM, except that it always succeeds and
+-- the resulting list might be smaller than the given list.
+mapUntilError
+    :: Monad m
+    => (a -> ExceptT e m b)
+       -- ^ Action to run
+    -> [a]
+       -- ^ Elements
+    -> ExceptT e m [b]
+       -- ^ Results
+mapUntilError action (x:xs) = ExceptT $ runExceptT (action x) >>= \case
+    Left _ -> pure $ Right []
+    Right r -> runExceptT $ do
+        rs <- mapUntilError action xs
+        pure (r:rs)
+mapUntilError _ [] = pure []
+
+-- * Slotting calculation utilities
+
+-- | Gets the slot from a block header.
+headerSlot :: BlockHeader -> SlotId
+headerSlot bh = SlotId
+    (epochIndex (bh :: BlockHeader)) (slotNumber (bh :: BlockHeader))
+
+-- | Calculates which epochs to fetch, given a number of slots, and the start
+-- point. It takes into account the latest block available, and that the most
+-- recent epoch is never available in a pack file.
+epochRange
+    :: SlotCount
+        -- ^ Number of slots
+    -> SlotId
+        -- ^ Start point
+    -> SlotId
+        -- ^ Latest block available
+    -> [EpochIndex]
+epochRange
+    numBlocks
+    (SlotId startEpoch (LocalSlotIndex startSlot)) (SlotId tipEpoch _)
+    = [startEpoch .. min (tipEpoch - 1) (startEpoch + fromIntegral numEpochs)]
+    where
+        numEpochs = (numBlocks + fromIntegral startSlot) `div` slotsPerEpoch
+
+-- | Predicate returns true iff the block is from the given slot or a later one.
+blockIsSameOrAfter :: SlotId -> Block -> Bool
+blockIsSameOrAfter s = (>= s) . headerSlot . header
+
+-- | Predicate returns true iff the block is after then given slot
+blockIsAfter :: SlotId -> Block -> Bool
+blockIsAfter s = (> s) . headerSlot . header
+
+-- | Predicate returns true iff the block is before the given slot.
+blockIsBefore :: SlotId -> Block -> Bool
+blockIsBefore s = (< s) . headerSlot . header
+
+-- | @blockIsBetween start end@ Returns true if the block is in within the
+-- interval @[start, end)@.
+blockIsBetween :: SlotId -> SlotId -> Block -> Bool
+blockIsBetween start end b = blockIsSameOrAfter start b && blockIsBefore end b

src/Cardano/ChainProducer/RustHttpBridge/Api.hs

@@ -7,7 +7,7 @@ module Cardano.ChainProducer.RustHttpBridge.Api
     , api
     , Block (..)
     , BlockHeader (..)
-    , EpochId (..)
+    , EpochIndex (..)
     , NetworkName (..)
     ) where
 
@@ -26,6 +26,7 @@ import Servant.Extra.ContentTypes
     ( CBOR, ComputeHash, FromCBOR (..), Hash, Packed, WithHash )
 
 import qualified Cardano.Wallet.Primitive as Primitive
+import qualified Cardano.Wallet.Slotting as Slotting
 
 api :: Proxy Api
 api = Proxy
@@ -46,7 +47,7 @@ type GetBlockByHash
 type GetEpochById
     =  Capture "networkName" NetworkName
     :> "epoch"
-    :> Capture "epochId" EpochId
+    :> Capture "epochId" EpochIndex
     :> Get '[Packed CBOR] [Block]
 
 -- | Retrieve the header of the latest known block.
@@ -75,12 +76,12 @@ instance FromCBOR BlockHeader where
 
 -- | Represents a unique epoch.
 --
-newtype EpochId = EpochId
-  { getEpochId :: Primitive.EpochId
+newtype EpochIndex = EpochIndex
+  { getEpochIndex :: Slotting.EpochIndex
   } deriving (Eq, Show)
 
-instance ToHttpApiData (EpochId) where
-    toUrlPiece = toUrlPiece . Primitive.getEpochId . getEpochId
+instance ToHttpApiData (EpochIndex) where
+    toUrlPiece = toUrlPiece . Slotting.getEpochIndex . getEpochIndex
 
 -- | Represents the name of a Cardano network.
 --
@@ -90,4 +91,3 @@ newtype NetworkName = NetworkName
 
 instance ToHttpApiData NetworkName where
     toUrlPiece = getNetworkName
-