Merge #3988

3988: [ADP-3031] Simplify checkpoint pruning, take 3 r=HeinrichApfelmus a=HeinrichApfelmus

### Overview


In this pull request, we consolidate and simplify the creation and pruning of checkpoints.

Specifically, we introduce a function `extendAndPrune` that computes a delta which

* adds new checkpoints
* prunes the existing checkpoints

based on their block height.

### Details

* The mechanism for creating checkpoints has changed. Specifically, when synchronizing the chain far away from the `tip`, at most two checkpoints are kept: genesis and the latest synchronization point. We only keep multiple checkpoints when we are within `epochStability` of the tip, as we expect rollbacks only then.
* The `CheckpointPolicy` is tested in the existing module `Cardano.Wallet.Checkpoints.PolicySpec`.

### Comments

* This task evolved out of ADP-1497. Previous attempts to implement this are
    * #3159
    * #3369 

### Issue Number

ADP-3031

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

lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs

@@ -138,8 +138,6 @@ import Data.Function
     ( (&) )
 import Data.Generics.Internal.VL.Lens
     ( view, (^.) )
-import Data.Generics.Wrapped
-    ( _Unwrapped )
 import Data.Maybe
     ( fromJust, isJust )
 import Data.Proxy
@@ -2644,8 +2642,16 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do
         dest <- emptyWallet ctx
         let depositAmt = Quantity 1_000_000
 
-        pool1:pool2:_ <- map (view $ _Unwrapped . #id) . snd <$> unsafeRequest @[ApiT StakePool]
-            ctx (Link.listStakePools arbitraryStake) Empty
+        -- Note: In the local cluster, some of the pools retire early.
+        -- When running the test in isolation, we have to delegate
+        -- to pools which will retire later.
+        let won'tRetire pool' = case pool' ^. #retirement of
+                Nothing -> True
+                Just epoch -> epoch ^. #epochNumber >= 100
+        pools <- filter won'tRetire . map getApiT . snd <$>
+            unsafeRequest @[ApiT StakePool] ctx
+                (Link.listStakePools arbitraryStake) Empty
+        let pool1:pool2:_ = map (view #id) pools
 
         let delegationJoin = Json [json|{
                 "delegations": [{
@@ -2891,28 +2897,29 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do
             , expectResponseCode HTTP.status202
             ]
 
-        let txid3 = getFromResponse (#id) submittedTx4
-        let queryTx3 = Link.getTransaction @'Shelley src (ApiTxId txid3)
-        rGetTx3 <- request @(ApiTransaction n) ctx queryTx3 Default Empty
-        verify rGetTx3
-            [ expectResponseCode HTTP.status200
-            , expectField #depositTaken (`shouldBe` Quantity 0)
-            , expectField #depositReturned (`shouldBe` depositAmt)
-            ]
-
-        eventually "Wallet is not delegating" $ do
-            request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty
-                >>= flip verify
-                    [ expectField #delegation (`shouldBe` notDelegating [])
-                    ]
+        -- Wait for the transaction to be accepted into the ledger
+        let txidQuit = getFromResponse (#id) submittedTx4
+            queryTxQuit = Link.getTransaction @'Shelley src (ApiTxId txidQuit)
+        eventually "Wait for ledger to accept Quit transaction" $ do
+            rGetTxQuit <- request @(ApiTransaction n) ctx queryTxQuit Default Empty
+            verify rGetTxQuit
+                [ expectResponseCode HTTP.status200
+                , expectField #insertedAt (`shouldSatisfy` isJust)
+                ]
 
-        -- transaction history shows deposit returned
-        rGetTx4 <- request @(ApiTransaction n) ctx queryTx3 Default Empty
-        verify rGetTx4
+        -- Wallet will stop delegating
+        rGetTxQuit' <- request @(ApiTransaction n) ctx queryTxQuit Default Empty
+        verify rGetTxQuit'
             [ expectResponseCode HTTP.status200
             , expectField #depositTaken (`shouldBe` Quantity 0)
             , expectField #depositReturned (`shouldBe` depositAmt)
             ]
+        eventually "Wallet not delegating" $ do
+            rGetQuit <- request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty
+            verify rGetQuit
+                [ expectResponseCode HTTP.status200
+                , expectField #delegation (`shouldBe` notDelegating [])
+                ]
 
     it "TRANS_NEW_JOIN_01b - Invalid pool id" $ \ctx -> runResourceT $ do
         wa <- fixtureWallet ctx

lib/wallet/src/Cardano/Wallet.hs

@@ -330,7 +330,9 @@ import Cardano.Wallet.Address.Keys.WalletKey
 import Cardano.Wallet.Address.States.IsOwned
     ( isOwned )
 import Cardano.Wallet.Checkpoints
-    ( DeltaCheckpoints (..), extendCheckpoints, pruneCheckpoints )
+    ( DeltaCheckpoints (..), extendAndPrune )
+import Cardano.Wallet.Checkpoints.Policy
+    ( sparseArithmetic )
 import Cardano.Wallet.DB
     ( DBFresh (..)
     , DBLayer (..)
@@ -355,6 +357,7 @@ import Cardano.Wallet.DB.WalletState
     , DeltaWalletState1 (..)
     , WalletState (..)
     , fromWallet
+    , getBlockHeight
     , getLatest
     , getSlot
     )
@@ -1219,22 +1222,19 @@ restoreBlocks ctx tr blocks nodeTip = db & \DBLayer{..} -> atomically $ do
     let finalitySlot = nodeTip ^. #slotNo
             - stabilityWindowShelley slottingParams
 
-    -- Checkpoint deltas
     let wcps = snd . fromWallet <$> cps
-        deltaPutCheckpoints =
-            extendCheckpoints
+        epochStability' = fromIntegral $ getQuantity epochStability
+        deltaCheckpoints wallet =
+            extendAndPrune
                 getSlot
-                (view $ #currentTip . #blockHeight)
-                epochStability
-                (nodeTip ^. #blockHeight)
+                (fromIntegral . getBlockHeight)
+                (sparseArithmetic epochStability')
+                (fromIntegral $ getQuantity $ localTip ^. #blockHeight)
+                    -- nodeTip instead of localTip should work as well,
+                    -- but for some reason, the integration tests
+                    -- become flakier.
                 wcps
-
-        deltaPruneCheckpoints wallet =
-            pruneCheckpoints
-                (view $ #currentTip . #blockHeight)
-                epochStability
-                (localTip ^. #blockHeight)
-                (wallet ^. #checkpoints)
+                (checkpoints wallet)
 
     let
         -- NOTE: We have to update the 'Prologue' as well,
@@ -1263,14 +1263,11 @@ restoreBlocks ctx tr blocks nodeTip = db & \DBLayer{..} -> atomically $ do
             liftIO $ logDelegation delegation
             putDelegationCertificate walletState cert slotNo
 
-    Delta.onDBVar walletState $ Delta.update $ \_wallet ->
+    Delta.onDBVar walletState $ Delta.update $ \wallet ->
         deltaPrologue
-        <> [ UpdateCheckpoints deltaPutCheckpoints ]
+        <> [ UpdateCheckpoints $ deltaCheckpoints wallet ]
         <> deltaPruneSubmissions
 
-    Delta.onDBVar walletState $ Delta.update $ \wallet ->
-        [ UpdateCheckpoints $ deltaPruneCheckpoints wallet ]
-
     liftIO $ do
         traceWith tr $ MsgDiscoveredTxs txs
         traceWith tr $ MsgDiscoveredTxsContent txs