make 'sparseCheckpoints' API a bit more future proof

  The previous version could possibly lead to an unaware developer tweaking parameters in a way that would generate invalid configuration. This new version makes it more difficult / safer.

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

@@ -24,6 +24,7 @@ module Cardano.Wallet.DB
     , sparseCheckpoints
     , SparseCheckpointsConfig (..)
     , defaultSparseCheckpointsConfig
+    , gapSize
 
       -- * Errors
     , ErrRemovePendingTx (..)
@@ -60,14 +61,10 @@ import Control.Monad.IO.Class
     ( MonadIO )
 import Control.Monad.Trans.Except
     ( ExceptT, runExceptT )
-import Data.Function
-    ( (&) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Word
-    ( Word32, Word64 )
-import GHC.Stack
-    ( HasCallStack )
+    ( Word32, Word64, Word8 )
 import Numeric.Natural
     ( Natural )
 
@@ -397,44 +394,58 @@ sparseCheckpoints
         -- ^ The list of checkpoint heights that should be kept in DB.
 sparseCheckpoints cfg blkH  =
     let
-        SparseCheckpointsConfig{gapsSize,edgeSize,epochStability} = cfg
+        SparseCheckpointsConfig{edgeSize,epochStability} = cfg
+        g = gapSize cfg
         h = getQuantity blkH
+        e = fromIntegral edgeSize
 
         minH =
             let x = if h < epochStability then 0 else h - epochStability
-            in gapsSize * (x `div` gapsSize)
+            in g * (x `div` g)
 
         initial   = 0
-        longTerm  = [minH,minH+gapsSize..h]
-        shortTerm = if h < edgeSize
+        longTerm  = [minH,minH+g..h]
+        shortTerm = if h < e
             then [0..h]
-            else [h-edgeSize,h-edgeSize+1..h]
+            else [h-e,h-e+1..h]
     in
         L.sort (L.nub $ initial : (longTerm ++ shortTerm))
-        & guardGapsSize
-        & guardEdgeSize
-    where
-        guardGapsSize :: HasCallStack => a -> a
-        guardGapsSize
-            | gapsSize cfg > 0 && gapsSize cfg < epochStability cfg = id
-            | otherwise = error "pre-condition failed for gapsSize"
-
-        guardEdgeSize :: HasCallStack => a -> a
-        guardEdgeSize
-            | edgeSize cfg <= epochStability cfg = id
-            | otherwise = error "pre-condition failed for edgeSize"
 
 -- | 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
-    { gapsSize :: Word32
-    , edgeSize :: Word32
+    { edgeSize :: Word8
     , epochStability :: Word32
     } deriving Show
 
--- | A sensible default to use in production.
+-- | A sensible default to use in production. See also 'SparseCheckpointsConfig'
 defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig
-defaultSparseCheckpointsConfig (Quantity k) = SparseCheckpointsConfig
-    { gapsSize = k `div` 3
-    , edgeSize = 10
-    , epochStability = k
-    }
+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/test/unit/Cardano/Wallet/DB/Properties.hs

@@ -30,6 +30,7 @@ import Cardano.Wallet.DB
     , SparseCheckpointsConfig (..)
     , cleanDB
     , defaultSparseCheckpointsConfig
+    , gapSize
     , sparseCheckpoints
     )
 import Cardano.Wallet.DB.Arbitrary
@@ -293,49 +294,49 @@ properties = do
     describe "sparseCheckpoints" $ do
         it "k=2160, h=42" $ \_ -> do
             let cfg = SparseCheckpointsConfig
-                    { gapsSize = 100
-                    , edgeSize = 10
+                    { edgeSize = 10
                     , epochStability = 2160
                     }
             let h = Quantity 42
 
             -- First unstable block: 0
             sparseCheckpoints cfg h `shouldBe`
-                [0,32,33,34,35,36,37,38,39,40,41,42]
+                [ 0
+                , 32,33,34,35,36,37,38,39,40,41 -- Short-term checkpoints
+                , 42 -- Tip
+                ]
 
         it "k=2160, h=2414" $ \_ -> do
             let cfg = SparseCheckpointsConfig
-                    { gapsSize = 100
-                    , edgeSize = 10
+                    { edgeSize = 10
                     , epochStability = 2160
                     }
             let h = Quantity 2714
             -- First unstable block: 554
             sparseCheckpoints cfg h `shouldBe`
-                [ 0    , 500  , 600  , 700  , 800  , 900
-                , 1000 , 1100 , 1200 , 1300 , 1400 , 1500
-                , 1600 , 1700 , 1800 , 1900 , 2000 , 2100
-                , 2200 , 2300 , 2400 , 2500 , 2600 , 2700
-                , 2704 , 2705 , 2706 , 2707 , 2708 , 2709
-                , 2710 , 2711 , 2712 , 2713 , 2714
+                [ 0
+                , 720, 1440, 2160               -- Long-term checkpoints
+
+                , 2704, 2705, 2706, 2707, 2708  -- Short-term checkpoints
+                , 2709, 2710, 2711, 2712, 2713  -- edgeSize = 10
+
+                , 2714  -- Tip
                 ]
 
         it "k=2160, h=2414" $ \_ -> do
             let cfg = SparseCheckpointsConfig
-                    { gapsSize = 100
-                    , edgeSize = 0
+                    { edgeSize = 0
                     , epochStability = 2160
                     }
             let h = Quantity 2714
             -- First unstable block: 554
             sparseCheckpoints cfg h `shouldBe`
-                [ 0    , 500  , 600  , 700  , 800  , 900
-                , 1000 , 1100 , 1200 , 1300 , 1400 , 1500
-                , 1600 , 1700 , 1800 , 1900 , 2000 , 2100
-                , 2200 , 2300 , 2400 , 2500 , 2600 , 2700
-                , 2714
+                [ 0
+                , 720, 1440, 2160               -- Long-term checkpoints
+                , 2714  -- Tip
                 ]
 
+
         it "The tip is always a checkpoint" $ \_ ->
             property prop_sparseCheckpointTipAlwaysThere
 
@@ -917,31 +918,38 @@ prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg h) = prop
     cps = sparseCheckpoints cfg (Quantity h)
 
     prop :: Property
-    prop = property $ fromIntegral (length cps) >= min (edgeSize cfg) h
-
+    prop = property $ fromIntegral (length cps) >= min e h
+      where
+        e = fromIntegral $ edgeSize cfg
 
 -- | Check that sparseCheckpoints always return checkpoints that can cover
 -- rollbacks up to `k` in the past. This means that, if the current block height
 -- is #3000, and `k=2160`, we should be able to rollback to #840. Since we make
--- checkpoints every gapsSize blocks, it means that block #800 should be in the list.
+-- checkpoints every gapSize blocks, it means that block #800 should be in the list.
 --
--- Note: The initial checkpoint at #0 will always be present.
+-- Note 1:
+--   The initial checkpoint at #0 will always be present.
+--
+-- Note 2:
+--   The property only holds for value of 'edgeSize' that are smaller than k
 prop_sparseCheckpointNoOlderThanK
     :: GenSparseCheckpointsArgs
     -> Property
-prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg h) = prop
+prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg h) =
+    (fromIntegral (edgeSize cfg) <= epochStability cfg) ==> prop
     & counterexample ("Checkpoints: " <> show ((\cp -> (age cp, cp)) <$> cps))
     & counterexample ("h=" <> show h)
   where
     cps = sparseCheckpoints cfg (Quantity h)
 
     prop :: Property
     prop = property $ flip all cps $ \cp ->
-        cp == 0 || (age cp - int (gapsSize cfg) <= int (epochStability cfg))
+        cp == 0 || (age cp - int (gapSize cfg) <= int (epochStability cfg))
 
     age :: Word32 -> Int
     age cp = int h - int cp
 
+
 -- | This property checks that, the checkpoints kept for an edge size of 0 are
 -- included in the list with a non-null edge size, all else equals.
 prop_sparseCheckpointEdgeSize0
@@ -1034,11 +1042,8 @@ data GenSparseCheckpointsArgs
 instance Arbitrary GenSparseCheckpointsArgs where
     arbitrary = do
         k <- (\x -> 10 + (x `mod` 1000)) <$> arbitrary
-        h <- (`mod` 100000) <$> arbitrary
-        cfg <- SparseCheckpointsConfig
-            <$> choose (1, k-1)
-            <*> choose (0, 10)
-            <*> pure k
+        h <- (`mod` 10000) <$> arbitrary
+        cfg <- SparseCheckpointsConfig <$> arbitrary <*> pure k
         pure $ GenSparseCheckpointsArgs cfg h
 
 -- This functions generate `h` "block header" (modeled as a Word32), grouped in
@@ -1051,7 +1056,8 @@ genBatches
     -> Gen Batches
 genBatches (GenSparseCheckpointsArgs cfg h) = do
     bs <- go [0..h] []
-    let oneByOne = pure <$> [h+1..h+edgeSize cfg]
+    let e = fromIntegral $ edgeSize cfg
+    let oneByOne = pure <$> [h+1..h+e]
     pure (Batches (bs ++ oneByOne))
   where
     go :: [Word32] -> [[Word32]] -> Gen [[Word32]]
@@ -1060,5 +1066,5 @@ genBatches (GenSparseCheckpointsArgs cfg h) = do
         -- NOTE:
         -- Generate batches that can be larger than the chosen gap size, to make
         -- sure we generate realistic cases.
-        n <- choose (1, 3 * int (gapsSize cfg))
+        n <- fromIntegral <$> choose (1, 3 * gapSize cfg)
         go (drop n source) (take n source : batches)