Merge #3172

3172: Change `applyBlocks` to also accept `BlockSummary` r=HeinrichApfelmus a=HeinrichApfelmus

### Issue number

ADP-1422, ADP-1428

### Overview

[Light-mode][] (Epic ADP-1422) aims to make synchronisation to the blockchain faster by trusting an off-chain source of aggregated blockchain data. 

  [light-mode]: https://input-output-hk.github.io/cardano-wallet/design/specs/light-mode

In this pull request, we change the `applyBlocks` function to work with both a list of `Block` and a `BlockSummary`. Specifically, we introduce a function `applyBlockData` which performs the following steps:

* `discoverFromBlockData`: discover addresses and and transaction data (`ChainEvents`) contained in the sequence of blocks
* `applyBlockEventsToUTxO`: update the wallet UTxO from the given `ChainEvents`.

### Details

* Property tests for `discoverFromBlockData` check that address discovery gives the same result for both a `List` of blocks and a `Summary`.
* When processing a `List` of `Block`, we have to be a bit careful about performance, because we need to traverse ~ 32M transactions (as of Feb 2022). In this case, the `transactions` contained in `BlockEvents` are essentially a full copy of the `transactions` in `Block`. The best way to copy data is to copy a single reference to the data; for this purpose we introduce a `Sublist` type which avoids deconstructing and reconstructing the transaction list in the case where we do not filter transactions (`All`).
* In order to preserve the current checkpointing mechanism, `applyBlocks` actually calls `applyBlockData` repeatedly instead of passing the full list of blocks. I will need to rethink the checkpointing mechanism in the future — the main issue is that in its current form, a consumer of `BlockSummary` cannot ask for a specific block height in order to set a suitable checkpoint there. In the future, the checkpointing logic will need to mediate between producer and consumer.

### Comments

* I expect a slight regression in benchmarks, due to overhead involved in calling `applyBlockData` repeatedly. However, the introduction of `Sublist` should prevent a serious deterioration.

Co-authored-by: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>

Author: iohk-bors[bot]

lib/core/src/Cardano/Wallet.hs

@@ -385,6 +385,7 @@ import Cardano.Wallet.Primitive.Types
     , WalletMetadata (..)
     , WalletName (..)
     , WalletPassphraseInfo (..)
+    , WithOrigin (..)
     , dlgCertPoolId
     , toSlot
     , wholeRange
@@ -1047,17 +1048,16 @@ restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomic
         , pretty (firstHeader blocks)
         ]
 
-
-    (filteredBlocks, cps') <- liftIO $ NE.unzip <$> applyBlocks @s blocks cp0
+    (filteredBlocks', cps') <- liftIO $ NE.unzip <$> applyBlocks @s blocks cp0
     let cps = NE.map snd cps'
-    let List blocks' = blocks
-        slots = view #slotNo . view #header <$> blocks'
-        delegations = view #delegations <$> filteredBlocks
-        slotPoolDelegations =
-            [ (slotNo, cert)
-            | (slotNo, certs) <- NE.toList $ NE.zip slots delegations
-            , cert <- certs
+        filteredBlocks = concat filteredBlocks'
+    let slotPoolDelegations =
+            [ (pseudoSlotNo (fblock ^. #slot), cert)
+            | fblock <- filteredBlocks
+            , cert <- view #delegations fblock
             ]
+        pseudoSlotNo Origin = 0
+        pseudoSlotNo (At sl) = sl
     let txs = fold $ view #transactions <$> filteredBlocks
     let epochStability = (3*) <$> getSecurityParameter sp
     let localTip = currentTip $ NE.last cps
@@ -1068,6 +1068,14 @@ restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomic
         liftIO $ logDelegation delegation
         putDelegationCertificate wid cert slotNo
 
+    -- FIXME LATER during ADP-1403
+    -- We need to rethink checkpoint creation and consider the case
+    -- where the blocks are given as a 'Summary' and not a full 'List'
+    -- of blocks. In this case, it could happen that the current
+    -- scheme fails to create sufficiently many checkpoint as
+    -- it was never able to touch the corresponding block.
+    -- For now, we avoid this situation by being always supplied a 'List'
+    -- in the unstable region close to the tip.
     let unstable = Set.fromList $ sparseCheckpoints cfg (nodeTip ^. #blockHeight)
             where
                 -- NOTE

lib/core/src/Cardano/Wallet/Primitive/BlockSummary.hs

@@ -23,9 +23,16 @@ module Cardano.Wallet.Primitive.BlockSummary
     , BlockEvents (..)
     , fromEntireBlock
 
-    -- * Testing
+    -- * Sublist
+    , Sublist
+    , filterSublist
+    , wholeList
+
+    -- * Internal & Testing
     , summarizeOnTxOut
     , mkChainEvents
+    , mergeSublist
+    , unsafeMkSublist
     ) where
 
 import Prelude
@@ -45,6 +52,8 @@ import Cardano.Wallet.Primitive.Types.Address
     ( Address )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Tx (..), TxOut (..) )
+import Data.Foldable
+    ( Foldable (toList) )
 import Data.Functor.Identity
     ( Identity (..) )
 import Data.List.NonEmpty
@@ -123,17 +132,59 @@ toAscBlockEvents (ChainEvents bs) = Map.elems bs
 data BlockEvents = BlockEvents
     { slot :: !Slot
     , blockHeight :: !(Quantity "block" Word32)
-    , transactions :: [(Int, Tx)]
+    , transactions :: Sublist Tx
         -- ^ (Index of the transaction within the block, transaction data)
         -- INVARIANT: The list is ordered by ascending index.
-    , delegations :: [(Int, DelegationCertificate)]
+    , delegations :: Sublist DelegationCertificate
         -- ^ (Index of the delegation within the block, delegation data)
         -- INVARIANT: The list is ordered by ascending index.
     } deriving (Eq, Ord, Generic, Show)
 
+-- | A data type representing a sublist of a total list.
+-- Such a sublist typically arises by filtering and keeps
+-- track of the indices of the filtered list elements.
+--
+-- The main purpose of this data type is optimization:
+-- When processing whole 'Block', we want to avoid copying
+-- and redecorating the entire list of transactions in that 'Block';
+-- instead, we want to copy a pointer to this list.
+data Sublist a = All [a] | Some [(Int, a)]
+    deriving (Eq, Ord, Show)
+
+-- | Construct a 'Sublist' representing the whole list.
+wholeList :: [a] -> Sublist a
+wholeList = All
+
+-- | Construct a 'Sublist' from a list of indexed items.
+unsafeMkSublist :: [(Int,a)] -> Sublist a
+unsafeMkSublist = Some
+
+-- | Filter a 'Sublist' by a predicate.
+filterSublist :: (a -> Bool) -> Sublist a -> Sublist a
+filterSublist p (All xs) = filterSublist p $ Some $ zip [0..] xs
+filterSublist p (Some ixs) = Some [ ix | ix <- ixs, p (snd ix) ]
+
+instance Functor Sublist where
+    fmap f (All xs) = All (map f xs)
+    fmap f (Some ixs) = Some [ (i, f x) | (i,x) <- ixs ]
+
+instance Foldable Sublist where
+    foldr f b = foldr f b . toList
+    null = null . toList
+    toList (All as) = as
+    toList (Some ixs) = map snd ixs
+
+-- | Returns 'True' if the 'BlockEvents' contains empty
+-- 'transactions' and 'delegations'.
 nullBlockEvents :: BlockEvents -> Bool
-nullBlockEvents BlockEvents{transactions=[],delegations=[]} = True
-nullBlockEvents _ = False
+nullBlockEvents BlockEvents{transactions,delegations}
+    = null transactions && null delegations
+
+-- | Merge two 'Sublist' assuming that they are sublists of the /same/ list.
+mergeSublist :: Sublist a -> Sublist a -> Sublist a
+mergeSublist (All xs) _ = All xs -- result cannot be larger
+mergeSublist _ (All ys) = All ys
+mergeSublist (Some xs) (Some ys) = Some $ mergeOn fst const xs ys
 
 -- | Merge block events that belong to the same block.
 mergeSameBlock :: BlockEvents -> BlockEvents -> BlockEvents
@@ -143,8 +194,8 @@ mergeSameBlock
   = BlockEvents
     { slot
     , blockHeight
-    , transactions = mergeOn fst const txs1 txs2
-    , delegations = mergeOn fst const dlg1 dlg2
+    , transactions = mergeSublist txs1 txs2
+    , delegations = mergeSublist dlg1 dlg2
     }
 
 -- | Merge two lists in sorted order. Remove duplicate items.
@@ -176,8 +227,8 @@ fromEntireBlock :: Block -> BlockEvents
 fromEntireBlock Block{header,transactions,delegations} = BlockEvents
     { slot = toSlot $ chainPointFromBlockHeader header
     , blockHeight = Block.blockHeight header
-    , transactions = zip [0..] transactions
-    , delegations = zip [0..] delegations
+    , transactions = All transactions
+    , delegations = All delegations
     }
 
 {-------------------------------------------------------------------------------
@@ -201,15 +252,15 @@ filterBlock question block = case fromEntireBlock block of
         { slot
         , blockHeight
         , transactions = case question of
-            Left addr -> filter (isRelevantTx addr) transactions
-            Right _   -> []
+            Left addr -> filterSublist (isRelevantTx addr) transactions
+            Right _   -> Some []
         , delegations = case question of
-            Left _     -> []
-            Right racc -> filter (isRelevantDelegation racc) delegations
+            Left _     -> Some []
+            Right racc -> filterSublist (isRelevantDelegation racc) delegations
         }
   where
     -- NOTE: Currently used the full address,
     -- containing both payment and staking parts.
     -- We may want to query only for the payment part at some point.
-    isRelevantTx addr = any ((addr ==) . address) . outputs . snd
-    isRelevantDelegation racc = (racc == ) . dlgCertAccount . snd
+    isRelevantTx addr = any ((addr ==) . address) . outputs
+    isRelevantDelegation racc = (racc == ) . dlgCertAccount