Merge #3399

3399: Reduce database blocking in light-mode r=HeinrichApfelmus a=HeinrichApfelmus

### Issue number

ADP-2012

### Overview

This pull request fixes an issue in light-mode where a lock on the database was kept while fetching transactions from an external blockchain data source.

### Details

* The field `atomically` of the `DBLayer` allows us to do atomic database operations.
* Instead of wrapping the entire body of `restoreBlocks` into a call to `atomically`, we now wrap the reading and writing separately.
    * In principle, this could lead to trouble when two calls to `restoreBlocks` interleave — the checkpoint which we have read need no longer agree with the one we are writing to.
    * However, the old code also assumes that the calls to `restoreBlocks` are not interleaved. More generally, we expect that the callbacks stored in a `ChainFollower` are called sequentially.




Co-authored-by: Heinrich Apfelmus <[email protected]>

lib/core/src/Cardano/Wallet.hs

@@ -1060,6 +1060,9 @@ rollbackBlocks ctx wid point = db & \DBLayer{..} -> do
 
 -- | Apply the given blocks to the wallet and update the wallet state,
 -- transaction history and corresponding metadata.
+--
+-- Concurrency: `restoreBlocks` is not atomic; we assume that
+-- it is called in a sequential fashion for each wallet.
 restoreBlocks
     :: forall ctx s k.
         ( HasDBLayer IO s k ctx
@@ -1074,17 +1077,23 @@ restoreBlocks
     -> BlockData IO (Either Address RewardAccount) ChainEvents s
     -> BlockHeader
     -> ExceptT ErrNoSuchWallet IO ()
-restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomically $ do
-    cp0  <- withNoSuchWallet wid (readCheckpoint wid)
-    sp   <- liftIO $ currentSlottingParameters nl
-
+restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> do
+    sp  <- liftIO $ currentSlottingParameters nl
+    cp0 <- mapExceptT atomically $
+        withNoSuchWallet wid (readCheckpoint wid)
     unless (cp0 `isParentOf` firstHeader blocks) $ fail $ T.unpack $ T.unwords
         [ "restoreBlocks: given chain isn't a valid continuation."
         , "Wallet is at:", pretty (currentTip cp0)
         , "but the given chain continues starting from:"
         , pretty (firstHeader blocks)
         ]
 
+    -- NOTE on concurrency:
+    -- In light-mode, 'applyBlocks' may take some time to retrieve
+    -- transaction data. We avoid blocking the database by
+    -- not wrapping this into a call to 'atomically'.
+    -- However, this only works if the latest database checkpoint, `cp0`,
+    -- does not change in the meantime.
     (filteredBlocks', cps') <- liftIO $ NE.unzip <$> applyBlocks @s blocks cp0
     let cps = NE.map snd cps'
         filteredBlocks = concat filteredBlocks'
@@ -1099,12 +1108,6 @@ restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomic
     let epochStability = (3*) <$> getSecurityParameter sp
     let localTip = currentTip $ NE.last cps
 
-    putTxHistory wid txs
-    updatePendingTxForExpiry wid (view #slotNo localTip)
-    forM_ slotPoolDelegations $ \delegation@(slotNo, cert) -> do
-        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'
@@ -1150,15 +1153,22 @@ restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomic
             | wcp <- map (snd . fromWallet) cpsKeep
             ]
 
-    liftIO $ mapM_ logCheckpoint cpsKeep
-    ExceptT $ modifyDBMaybe walletsDB $
-        adjustNoSuchWallet wid id $ \_ -> Right ( delta, () )
-
-    prune wid epochStability
-
-    liftIO $ do
-        traceWith tr $ MsgDiscoveredTxs txs
-        traceWith tr $ MsgDiscoveredTxsContent txs
+    mapExceptT atomically $ do
+        putTxHistory wid txs
+        updatePendingTxForExpiry wid (view #slotNo localTip)
+        forM_ slotPoolDelegations $ \delegation@(slotNo, cert) -> do
+            liftIO $ logDelegation delegation
+            putDelegationCertificate wid cert slotNo
+
+        liftIO $ mapM_ logCheckpoint cpsKeep
+        ExceptT $ modifyDBMaybe walletsDB $
+            adjustNoSuchWallet wid id $ \_ -> Right ( delta, () )
+
+        prune wid epochStability
+
+        liftIO $ do
+            traceWith tr $ MsgDiscoveredTxs txs
+            traceWith tr $ MsgDiscoveredTxsContent txs
   where
     nl = ctx ^. networkLayer
     db = ctx ^. dbLayer @IO @s @k