Move (old) checkpoint creation logic to Cardano.Wallet.Checkpoints

lib/core/cardano-wallet-core.cabal

@@ -452,6 +452,7 @@ test-suite unit
       Cardano.Wallet.Api.TypesSpec
       Cardano.Wallet.ApiSpec
       Cardano.Wallet.Checkpoints.PolicySpec
+      Cardano.Wallet.CheckpointsSpec
       Cardano.Wallet.CoinSelectionSpec
       Cardano.Wallet.CoinSelection.InternalSpec
       Cardano.Wallet.CoinSelection.Internal.BalanceSpec

lib/core/src/Cardano/Wallet.hs

@@ -228,7 +228,11 @@ import Cardano.Slotting.Slot
 import Cardano.Wallet.Address.Book
     ( AddressBookIso, Prologue (..), getPrologue )
 import Cardano.Wallet.Checkpoints
-    ( DeltaCheckpoints (..) )
+    ( DeltaCheckpoints (..)
+    , SparseCheckpointsConfig (..)
+    , defaultSparseCheckpointsConfig
+    , sparseCheckpoints
+    )
 import Cardano.Wallet.CoinSelection
     ( Selection
     , SelectionBalanceError (..)
@@ -258,9 +262,6 @@ import Cardano.Wallet.DB
     , ErrPutLocalTxSubmission (..)
     , ErrRemoveTx (..)
     , ErrWalletAlreadyExists (..)
-    , SparseCheckpointsConfig (..)
-    , defaultSparseCheckpointsConfig
-    , sparseCheckpoints
     )
 import Cardano.Wallet.DB.WalletState
     ( DeltaWalletState1 (..)

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

@@ -1,4 +1,6 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -20,6 +22,12 @@ module Cardano.Wallet.Checkpoints
 
     -- * Delta types
     , DeltaCheckpoints (..)
+
+    -- * Checkpoint hygiene
+    , SparseCheckpointsConfig (..)
+    , defaultSparseCheckpointsConfig
+    , sparseCheckpoints
+    , gapSize
     ) where
 
 import Prelude
@@ -32,12 +40,17 @@ import Data.Map.Strict
     ( Map )
 import Data.Maybe
     ( fromMaybe )
+import Data.Quantity
+    ( Quantity (..) )
+import Data.Word
+    ( Word32, Word8 )
 import Fmt
     ( Buildable (..), listF )
 import GHC.Generics
     ( Generic )
 
 import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Data.List as L
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
@@ -132,3 +145,120 @@ instance Buildable (DeltaCheckpoints a) where
     build (PutCheckpoint slot _) = "PutCheckpoint " <> build slot
     build (RollbackTo slot) = "RollbackTo " <> build slot
     build (RestrictTo slots) = "RestrictTo " <> listF slots
+
+{-------------------------------------------------------------------------------
+    Checkpoint hygiene
+-------------------------------------------------------------------------------}
+-- | Storing EVERY checkpoints in the database is quite expensive and useless.
+-- We make the following assumptions:
+--
+-- - We can't rollback for more than `k=epochStability` blocks in the past
+-- - It is pretty fast to re-sync a few hundred blocks
+-- - Small rollbacks may occur more often than long one
+--
+-- So, as we insert checkpoints, we make sure to:
+--
+-- - Prune any checkpoint that more than `k` blocks in the past
+-- - Keep only one checkpoint every 100 blocks
+-- - But still keep ~10 most recent checkpoints to cope with small rollbacks
+--
+-- __Example 1__: Inserting `cp153`
+--
+--  ℹ: `cp142` is discarded and `cp153` inserted.
+--
+--  @
+--  Currently in DB:
+-- ┌───┬───┬───┬─  ──┬───┐
+-- │cp000 │cp100 │cp142 │..    ..│cp152 │
+-- └───┴───┴───┴─  ──┴───┘
+--  Want in DB:
+-- ┌───┬───┬───┬─  ──┬───┐
+-- │cp000 │cp100 │cp143 │..    ..│cp153 │
+-- └───┴───┴───┴─  ──┴───┘
+--  @
+--
+--
+--  __Example 2__: Inserting `cp111`
+--
+--  ℹ: `cp100` is kept and `cp111` inserted.
+--
+--  @
+--  Currently in DB:
+-- ┌───┬───┬───┬─  ──┬───┐
+-- │cp000 │cp100 │cp101 │..    ..│cp110 │
+-- └───┴───┴───┴─  ──┴───┘
+--  Want in DB:
+-- ┌───┬───┬───┬─  ──┬───┐
+-- │cp000 │cp100 │cp101 │..    ..│cp111 │
+-- └───┴───┴───┴─  ──┴───┘
+--  @
+--
+-- NOTE: There might be cases where the chain following "fails" (because, for
+-- example, the node has switch to a different chain, different by more than k),
+-- and in such cases, we have no choice but rolling back from genesis.
+-- Therefore, we need to keep the very first checkpoint in the database, no
+-- matter what.
+sparseCheckpoints
+    :: SparseCheckpointsConfig
+        -- ^ Parameters for the function.
+    -> Quantity "block" Word32
+        -- ^ A given block height
+    -> [Word32]
+        -- ^ The list of checkpoint heights that should be kept in DB.
+sparseCheckpoints cfg blkH  =
+    let
+        SparseCheckpointsConfig{edgeSize,epochStability} = cfg
+        g = gapSize cfg
+        h = getQuantity blkH
+        e = fromIntegral edgeSize
+
+        minH =
+            let x = if h < epochStability + g then 0 else h - epochStability - g
+            in g * (x `div` g)
+
+        initial   = 0
+        longTerm  = [minH,minH+g..h]
+        shortTerm = if h < e
+            then [0..h]
+            else [h-e,h-e+1..h]
+    in
+        L.sort (L.nub $ initial : (longTerm ++ shortTerm))
+
+-- | Captures the configuration for the `sparseCheckpoints` function.
+--
+-- NOTE: large values of 'edgeSize' aren't recommended as they would mean
+-- storing many unnecessary checkpoints. In Ouroboros Praos, there's a
+-- reasonable probability for small forks of a few blocks so it makes sense to
+-- maintain a small part that is denser near the edge.
+data SparseCheckpointsConfig = SparseCheckpointsConfig
+    { edgeSize :: Word8
+    , epochStability :: Word32
+    } deriving Show
+
+-- | A sensible default to use in production. See also 'SparseCheckpointsConfig'
+defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig
+defaultSparseCheckpointsConfig (Quantity epochStability) =
+    SparseCheckpointsConfig
+        { edgeSize = 5
+        , epochStability
+        }
+
+-- | A reasonable gap size used internally in 'sparseCheckpoints'.
+--
+-- 'Reasonable' means that it's not _too frequent_ and it's not too large. A
+-- value that is too small in front of k would require generating much more
+-- checkpoints than necessary.
+--
+-- A value that is larger than `k` may have dramatic consequences in case of
+-- deep rollbacks.
+--
+-- As a middle ground, we current choose `k / 3`, which is justified by:
+--
+-- - The current speed of the network layer (several thousands blocks per seconds)
+-- - The current value of k = 2160
+--
+-- So, `k / 3` = 720, which should remain around a second of time needed to catch
+-- up in case of large rollbacks.
+gapSize :: SparseCheckpointsConfig -> Word32
+gapSize SparseCheckpointsConfig{epochStability} =
+    epochStability `div` 3

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

@@ -1,8 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -19,12 +16,6 @@ module Cardano.Wallet.DB
     , DBFactory (..)
     , cleanDB
 
-      -- * Checkpoints
-    , sparseCheckpoints
-    , SparseCheckpointsConfig (..)
-    , defaultSparseCheckpointsConfig
-    , gapSize
-
       -- * Errors
     , ErrBadFormat(..)
     , ErrWalletAlreadyExists(..)
@@ -77,12 +68,10 @@ import Data.DBVar
 import Data.Quantity
     ( Quantity (..) )
 import Data.Word
-    ( Word32, Word8 )
+    ( Word32 )
 import UnliftIO.Exception
     ( Exception )
 
-import qualified Data.List as L
-
 -- | Instantiate database layers at will
 data DBFactory m s k = DBFactory
     { withDatabase :: forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a
@@ -380,117 +369,3 @@ newtype ErrWalletAlreadyExists
 cleanDB :: DBLayer m s k -> m ()
 cleanDB DBLayer{..} = atomically $
     listWallets >>= mapM_ (runExceptT . removeWallet)
-
--- | Storing EVERY checkpoints in the database is quite expensive and useless.
--- We make the following assumptions:
---
--- - We can't rollback for more than `k=epochStability` blocks in the past
--- - It is pretty fast to re-sync a few hundred blocks
--- - Small rollbacks may occur more often than long one
---
--- So, as we insert checkpoints, we make sure to:
---
--- - Prune any checkpoint that more than `k` blocks in the past
--- - Keep only one checkpoint every 100 blocks
--- - But still keep ~10 most recent checkpoints to cope with small rollbacks
---
--- __Example 1__: Inserting `cp153`
---
---  ℹ: `cp142` is discarded and `cp153` inserted.
---
---  @
---  Currently in DB:
--- ┌───┬───┬───┬─  ──┬───┐
--- │cp000 │cp100 │cp142 │..    ..│cp152 │
--- └───┴───┴───┴─  ──┴───┘
---  Want in DB:
--- ┌───┬───┬───┬─  ──┬───┐
--- │cp000 │cp100 │cp143 │..    ..│cp153 │
--- └───┴───┴───┴─  ──┴───┘
---  @
---
---
---  __Example 2__: Inserting `cp111`
---
---  ℹ: `cp100` is kept and `cp111` inserted.
---
---  @
---  Currently in DB:
--- ┌───┬───┬───┬─  ──┬───┐
--- │cp000 │cp100 │cp101 │..    ..│cp110 │
--- └───┴───┴───┴─  ──┴───┘
---  Want in DB:
--- ┌───┬───┬───┬─  ──┬───┐
--- │cp000 │cp100 │cp101 │..    ..│cp111 │
--- └───┴───┴───┴─  ──┴───┘
---  @
---
--- NOTE: There might be cases where the chain following "fails" (because, for
--- example, the node has switch to a different chain, different by more than k),
--- and in such cases, we have no choice but rolling back from genesis.
--- Therefore, we need to keep the very first checkpoint in the database, no
--- matter what.
-sparseCheckpoints
-    :: SparseCheckpointsConfig
-        -- ^ Parameters for the function.
-    -> Quantity "block" Word32
-        -- ^ A given block height
-    -> [Word32]
-        -- ^ The list of checkpoint heights that should be kept in DB.
-sparseCheckpoints cfg blkH  =
-    let
-        SparseCheckpointsConfig{edgeSize,epochStability} = cfg
-        g = gapSize cfg
-        h = getQuantity blkH
-        e = fromIntegral edgeSize
-
-        minH =
-            let x = if h < epochStability + g then 0 else h - epochStability - g
-            in g * (x `div` g)
-
-        initial   = 0
-        longTerm  = [minH,minH+g..h]
-        shortTerm = if h < e
-            then [0..h]
-            else [h-e,h-e+1..h]
-    in
-        L.sort (L.nub $ initial : (longTerm ++ shortTerm))
-
--- | Captures the configuration for the `sparseCheckpoints` function.
---
--- NOTE: large values of 'edgeSize' aren't recommended as they would mean
--- storing many unnecessary checkpoints. In Ouroboros Praos, there's a
--- reasonable probability for small forks of a few blocks so it makes sense to
--- maintain a small part that is denser near the edge.
-data SparseCheckpointsConfig = SparseCheckpointsConfig
-    { edgeSize :: Word8
-    , epochStability :: Word32
-    } deriving Show
-
--- | A sensible default to use in production. See also 'SparseCheckpointsConfig'
-defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig
-defaultSparseCheckpointsConfig (Quantity epochStability) =
-    SparseCheckpointsConfig
-        { edgeSize = 5
-        , epochStability
-        }
-
--- | A reasonable gap size used internally in 'sparseCheckpoints'.
---
--- 'Reasonable' means that it's not _too frequent_ and it's not too large. A
--- value that is too small in front of k would require generating much more
--- checkpoints than necessary.
---
--- A value that is larger than `k` may have dramatic consequences in case of
--- deep rollbacks.
---
--- As a middle ground, we current choose `k / 3`, which is justified by:
---
--- - The current speed of the network layer (several thousands blocks per seconds)
--- - The current value of k = 2160
---
--- So, `k / 3` = 720, which should remain around a second of time needed to catch
--- up in case of large rollbacks.
-gapSize :: SparseCheckpointsConfig -> Word32
-gapSize SparseCheckpointsConfig{epochStability} =
-    epochStability `div` 3

lib/core/src/Cardano/Wallet/DB/Layer.hs

@@ -78,16 +78,17 @@ import Cardano.DB.Sqlite.Delete
     , withRef
     )
 import Cardano.Wallet.Checkpoints
-    ( DeltaCheckpoints (..) )
+    ( DeltaCheckpoints (..)
+    , defaultSparseCheckpointsConfig
+    , sparseCheckpoints
+    )
 import Cardano.Wallet.DB
     ( DBFactory (..)
     , DBLayer (..)
     , ErrNoSuchTransaction (..)
     , ErrPutLocalTxSubmission (..)
     , ErrRemoveTx (..)
     , ErrWalletAlreadyExists (..)
-    , defaultSparseCheckpointsConfig
-    , sparseCheckpoints
     )
 import Cardano.Wallet.DB.Sqlite.Migration
     ( DefaultFieldValues (..), migrateManually )