Add checkpointPolicy field to ChainFollower

lib/core/src/Cardano/Wallet.hs

@@ -597,6 +597,7 @@ import qualified Cardano.Address.Script as CA
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Api.Shelley as Cardano
 import qualified Cardano.Crypto.Wallet as CC
+import qualified Cardano.Wallet.Checkpoints.Policy as CP
 import qualified Cardano.Wallet.CoinSelection as CS
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
@@ -969,7 +970,8 @@ restoreWallet
     -> WalletId
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} ->
-    let readChainPoints = liftIO $ atomically $ listCheckpoints wid
+    let checkpointPolicy = CP.defaultPolicy
+        readChainPoints = atomically $ listCheckpoints wid
         rollBackward =
             throwInIO . rollbackBlocks @_ @s @k ctx wid . toSlot
         rollForward' = \blockdata tip -> throwInIO $
@@ -979,13 +981,15 @@ restoreWallet ctx wid = db & \DBLayer{..} ->
       catchFromIO $ case (maybeDiscover, lightSync nw) of
         (Just discover, Just sync) ->
             sync $ ChainFollower
-                { readChainPoints
+                { checkpointPolicy
+                , readChainPoints
                 , rollForward = rollForward' . either List (Summary discover)
                 , rollBackward
                 }
         (_,_) -> -- light-mode not available
             chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
-                { readChainPoints
+                { checkpointPolicy
+                , readChainPoints
                 , rollForward = rollForward' . List
                 , rollBackward
                 }

lib/core/src/Cardano/Wallet/Checkpoints/Policy.hs

@@ -16,6 +16,7 @@ module Cardano.Wallet.Checkpoints.Policy
     , atTip
     , trailingArithmetic
     , sparseArithmetic
+    , defaultPolicy
     , gapSize
 
     -- * Internal invariants
@@ -181,6 +182,10 @@ sparseArithmetic epochStability =
     largeGap = gapSize epochStability
     n = epochStability `div` largeGap
 
+-- | A sensible default checkpoint policy; currently 'sparseArithmetic'.
+defaultPolicy :: BlockHeight -> CheckpointPolicy
+defaultPolicy = sparseArithmetic
+
 {- | A reasonable gap size used internally in 'sparseArithmeticPolicy'.
 
 'Reasonable' means that it's not _too frequent_ and it's not too large. A

lib/core/src/Cardano/Wallet/Network.hs

@@ -43,6 +43,8 @@ import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
+import Cardano.Wallet.Checkpoints.Policy
+    ( CheckpointPolicy )
 import Cardano.Wallet.Primitive.BlockSummary
     ( LightSummary )
 import Cardano.Wallet.Primitive.Slotting
@@ -196,12 +198,23 @@ instance Functor m => Functor (NetworkLayer m) where
 
 -- | A collection of callbacks to use with the 'chainSync' function.
 data ChainFollower m point tip blocks = ChainFollower
-    { readChainPoints :: m [point]
+    { checkpointPolicy :: Integer -> CheckpointPolicy
+        -- ^ The policy for creating and pruning checkpoints that
+        -- is used by the 'ChainFollower'.
+        -- The argument of this field is the @epochStability@.
+        --
+        -- Exposing this policy here enables any chain synchronizer 
+        -- which does not retrieve full blocks, such as 'lightSync',
+        -- to specifically target those block heights at which
+        -- the 'ChainFollower' intends to create checkpoints.
+
+    , readChainPoints :: m [point]
         -- ^ Callback for reading the local tip. Used to negotiate the
         -- intersection with the node.
         --
         -- A response of [] is interpreted as `Origin` -- i.e. the chain will be
         -- served from genesis.
+
     , rollForward :: blocks -> tip -> m ()
         -- ^ Callback for rolling forward.
         --
@@ -254,7 +267,8 @@ mapChainFollower
     -> ChainFollower m point2 tip2 blocks2
 mapChainFollower fpoint12 fpoint21 ftip fblocks cf =
     ChainFollower
-        { readChainPoints = map fpoint12 <$> readChainPoints cf
+        { checkpointPolicy = checkpointPolicy cf
+        , readChainPoints = map fpoint12 <$> readChainPoints cf
         , rollForward = \bs tip -> rollForward cf (fblocks bs) (ftip tip)
         , rollBackward = fmap fpoint12 . rollBackward cf . fpoint21
         }

lib/core/test/unit/Cardano/Wallet/Network/LightSpec.hs

@@ -59,6 +59,7 @@ import Test.QuickCheck
     , (===)
     )
 
+import qualified Cardano.Wallet.Checkpoints.Policy as CP
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
@@ -302,7 +303,10 @@ mkFollower
     -> ChainFollower m ChainPoint BlockHeader
         (LightBlocks m Block addr txs)
 mkFollower lift = ChainFollower
-    { readChainPoints = lift $ map chainPointFromBlockHeader . NE.toList <$> get
+    { checkpointPolicy = \epochStability ->
+        CP.atTip <> CP.atGenesis
+        <> CP.trailingArithmetic 2 (min 1 $ epochStability `div` 3)
+    , readChainPoints = lift $ map chainPointFromBlockHeader . NE.toList <$> get
     , rollForward = \blocks _tip -> lift $ modify $ \s -> case blocks of
         Left bs ->
             if latest s `isParentOf` NE.head bs

lib/shelley/bench/restore-bench.hs

@@ -84,7 +84,7 @@ import Cardano.Wallet.Logging
     ( trMessageText )
 import Cardano.Wallet.Network
     ( ChainFollowLog (..)
-    , ChainFollower (ChainFollower, readChainPoints, rollBackward, rollForward)
+    , ChainFollower (..)
     , ChainSyncLog (..)
     , NetworkLayer (..)
     )
@@ -247,6 +247,7 @@ import UnliftIO.Temporary
     ( withSystemTempFile )
 
 import qualified Cardano.Wallet as W
+import qualified Cardano.Wallet.Checkpoints.Policy as CP
 import qualified Cardano.Wallet.DB.Layer as Sqlite
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley
@@ -708,7 +709,8 @@ bench_baseline_restoration
         synchronizer <- async
             $ chainSync nw nullTracer
             $ ChainFollower
-            { readChainPoints  = readTVarIO chainPointT
+            { checkpointPolicy = const CP.atTip
+            , readChainPoints  = readTVarIO chainPointT
             , rollForward = \blocks ntip -> do
                 atomically $ writeTVar chainPointT
                     [chainPointFromBlockHeader ntip]

lib/shelley/src/Cardano/Wallet/Shelley/Network/Node.hs

@@ -56,7 +56,7 @@ import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer, produceTimings )
 import Cardano.Wallet.Network
     ( ChainFollowLog (..)
-    , ChainFollower (..)
+    , ChainFollower
     , ChainSyncLog (..)
     , ErrPostTx (..)
     , NetworkLayer (..)

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -231,6 +231,7 @@ import qualified Blockfrost.Client as BF
 import qualified Cardano.Pool.DB as PoolDb
 import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Types as Api
+import qualified Cardano.Wallet.Checkpoints.Policy as CP
 import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Monad as BFM
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
@@ -728,7 +729,8 @@ monitorStakePools tr (NetworkParameters gp sp _pp) nl DBLayer{..} =
             toChainPoint (BlockHeader sl _ h _) = ChainPoint sl h
 
         chainSync nl (contramap MsgChainMonitoring tr) $ ChainFollower
-            { readChainPoints = map toChainPoint <$> initCursor
+            { checkpointPolicy = CP.defaultPolicy
+            , readChainPoints = map toChainPoint <$> initCursor
             , rollForward  = rollForward
             , rollBackward = rollback
             }