From fc23a81d7a8d29318e611133acda955ef2cf704e Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 16 Sep 2020 12:53:54 +0200 Subject: [PATCH 1/6] remove storage of intermediate checkpoints in restore blocks This was a perhaps too-early optimization trying to reduce the time of rolling back. The `sparseCheckpoint` function return an empty list for pretty much the entire restoration, except when reaching the last k blocks where it'll return a list of checkpoints to save, sparse for older blocks and dense near the tip. With the current parameters, blocks are kept if: - Their blockheight is not older than (tip - k) or it is 0 - And their blockheight is a multiple of 100 or, they are near within 10 blocks from the last known block. We currently do this calculation and filtering in two places: 1. In `restoreBlocks`, to pre-filter checkpoints to store in the database 2. In `prune` from the wallet DBLayer, to garbage collect old checkpoints Yet, what (1) buys us is a very little gain on standard wallet, and a huge performance cost on large wallets. So let's analyze the two cases: A/ Small Wallets - The time to create a checkpoint is very small in front of the slot length. - Restoring blocks is fast, (up to 10K blocks per seconds on empty wallets). Therefore, rolling back of 2, 3 blocks or, 100 makes pretty much no difference. Being able to store more checkpoints near the tip adds very little benefits in terms of performances especially, for the first restoration. B/ Large Wallets - The time to create a checkpoint is important in front of the slot length (we've seen up to 4s). - Restoring blocks is still quite fast (the time needed for processing blocks remains quite small in front of the time needed to read and create new checkpoints). The main problem with large wallets occur when the wallet is almost synced and reaches the 10 last blocks of the chain. By trying to store intermediate checkpoints, not only does the wallet spent 10* more time in `restoreBlocks` than normally, but it also keep the database lock for all that duration. Consider the case where the wallet takes 4s to read, and 4s to create a checkpoint, plus some additional 2s to prune them (these are actual data from large exchanges), by default, 10s is spent for creating one checkpoint. And at least 40 more to create the intermediate ones. During this time, between 1 and 3 checkpoints have been created. So it already needs to prune out the last one it spends 12s to create and needs already to create new checkpoints right away. As a consequence, a lot of other functionalities are made needlessly slower than they could be, because for the whole duration of the `restoreBlocks` function, the wallet is holding the database lock. Now, what happen if we avoid storing the "intermediate" checkpoints in restore blocks: blocks near the tip will eventually get stored, but one by one. So, when we _just_ reach the top for the first time, we'll only store the last checkpoint. But then, the next 9 checkpoints created won't be pruned out. So, the worse that can happen is that the wallet is asked to rollback right after we've reached the tip and haven't created many checkpoints yet. Still, We would have at least two checkpoints in the past that are at most 2K blocks from the tip (because we fetch blocks by batches of 1000). So it's important that the batch size remains smaller than `k` so that we can be sure that there's always one checkpoint in the database. --- lib/core/src/Cardano/Wallet.hs | 19 ++++- lib/core/src/Cardano/Wallet/DB.hs | 27 ++++++-- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 3 +- .../test/unit/Cardano/Wallet/DB/Properties.hs | 69 +++++++++++++------ 4 files changed, 91 insertions(+), 27 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index de904a97f54..2e574773282 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -194,6 +194,8 @@ import Cardano.Wallet.DB , ErrRemovePendingTx (..) , ErrWalletAlreadyExists (..) , PrimaryKey (..) + , SparseCheckpointsConfig (..) + , defaultSparseCheckpointsConfig , sparseCheckpoints ) import Cardano.Wallet.Network @@ -843,7 +845,22 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall liftIO $ logDelegation delegation putDelegationCertificate (PrimaryKey wid) cert slotNo - let unstable = sparseCheckpoints k (nodeTip ^. #blockHeight) + let unstable = sparseCheckpoints cfg k (nodeTip ^. #blockHeight) + where + -- NOTE + -- The edge really is an optimization to avoid rolling back too + -- "far" in the past. Yet, we let the edge construct itself + -- organically once we reach the tip of the chain and start + -- processing blocks one by one. + -- + -- This prevents the wallet from trying to create too many + -- checkpoints at once during restoration which causes massive + -- performance degradation on large wallets. + -- + -- Rollback may still occur during this short period, but + -- rolling back from a few hundred blocks is relatively fast + -- anyway. + cfg = defaultSparseCheckpointsConfig { edgeSize = 0 } forM_ (NE.init cps) $ \cp' -> do let (Quantity h) = currentTip cp' ^. #blockHeight diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs index 950dbefff80..b45c04ce72f 100644 --- a/lib/core/src/Cardano/Wallet/DB.hs +++ b/lib/core/src/Cardano/Wallet/DB.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -20,6 +21,8 @@ module Cardano.Wallet.DB -- * Checkpoints , sparseCheckpoints + , SparseCheckpointsConfig (..) + , defaultSparseCheckpointsConfig -- * Errors , ErrRemovePendingTx (..) @@ -381,19 +384,20 @@ cleanDB DBLayer{..} = atomically $ -- Therefore, we need to keep the very first checkpoint in the database, no -- matter what. sparseCheckpoints - :: Quantity "block" Word32 + :: SparseCheckpointsConfig + -- ^ Parameters for the function. + -> Quantity "block" Word32 -- ^ Epoch Stability, i.e. how far we can rollback -> Quantity "block" Word32 -- ^ A given block height -> [Word32] -- ^ The list of checkpoint heights that should be kept in DB. -sparseCheckpoints epochStability blkH = +sparseCheckpoints cfg epochStability blkH = let - gapsSize = 100 - edgeSize = 10 - + SparseCheckpointsConfig{gapsSize,edgeSize} = cfg k = getQuantity epochStability h = getQuantity blkH + minH = let x = if h < k then 0 else h - k in gapsSize * (x `div` gapsSize) @@ -405,3 +409,16 @@ sparseCheckpoints epochStability blkH = else [h-edgeSize,h-edgeSize+1..h] in L.sort $ L.nub $ initial : (longTerm ++ shortTerm) + +-- | Captures the configuration for the `sparseCheckpoints` function. +data SparseCheckpointsConfig = SparseCheckpointsConfig + { gapsSize :: Word32 + , edgeSize :: Word32 + } deriving Show + +-- | A sensible default to use in production. +defaultSparseCheckpointsConfig :: SparseCheckpointsConfig +defaultSparseCheckpointsConfig = SparseCheckpointsConfig + { gapsSize = 1000 + , edgeSize = 10 + } diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index bfd602b7208..3ec80b08ce6 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -61,6 +61,7 @@ import Cardano.Wallet.DB , ErrRemovePendingTx (..) , ErrWalletAlreadyExists (..) , PrimaryKey (..) + , defaultSparseCheckpointsConfig , sparseCheckpoints ) import Cardano.Wallet.DB.Sqlite.TH @@ -1230,7 +1231,7 @@ pruneCheckpoints pruneCheckpoints wid cp = do let height = Quantity $ fromIntegral $ checkpointBlockHeight cp let epochStability = Quantity $ checkpointEpochStability cp - let cps = sparseCheckpoints epochStability height + let cps = sparseCheckpoints defaultSparseCheckpointsConfig epochStability height deleteCheckpoints wid [ CheckpointBlockHeight /<-. cps ] -- | Delete TxMeta values for a wallet. diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index 5fa43267fe3..3bd11fedb30 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs @@ -1,11 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} @@ -29,7 +27,9 @@ import Cardano.Wallet.DB , ErrNoSuchWallet (..) , ErrWalletAlreadyExists (..) , PrimaryKey (..) + , SparseCheckpointsConfig (..) , cleanDB + , defaultSparseCheckpointsConfig , sparseCheckpoints ) import Cardano.Wallet.DB.Arbitrary @@ -119,6 +119,7 @@ import Test.QuickCheck , Gen , Property , checkCoverage + , choose , counterexample , cover , elements @@ -289,17 +290,26 @@ properties = do describe "sparseCheckpoints" $ do it "k=2160, h=42" $ \_ -> do + let cfg = SparseCheckpointsConfig + { gapsSize = 100 + , edgeSize = 10 + } let k = Quantity 2160 let h = Quantity 42 + -- First unstable block: 0 - sparseCheckpoints k h `shouldBe` + sparseCheckpoints cfg k h `shouldBe` [0,32,33,34,35,36,37,38,39,40,41,42] it "k=2160, h=2414" $ \_ -> do + let cfg = SparseCheckpointsConfig + { gapsSize = 100 + , edgeSize = 10 + } let k = Quantity 2160 let h = Quantity 2714 -- First unstable block: 554 - sparseCheckpoints k h `shouldBe` + sparseCheckpoints cfg k h `shouldBe` [ 0 , 500 , 600 , 700 , 800 , 900 , 1000 , 1100 , 1200 , 1300 , 1400 , 1500 , 1600 , 1700 , 1800 , 1900 , 2000 , 2100 @@ -308,10 +318,26 @@ properties = do , 2710 , 2711 , 2712 , 2713 , 2714 ] + it "k=2160, h=2414" $ \_ -> do + let cfg = SparseCheckpointsConfig + { gapsSize = 100 + , edgeSize = 0 + } + let k = Quantity 2160 + let h = Quantity 2714 + -- First unstable block: 554 + sparseCheckpoints cfg k 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 + ] + it "The tip is always a checkpoint" $ \_ -> property prop_sparseCheckpointTipAlwaysThere - it "There's at least (min h 10) checkpoints" $ \_ -> + it "There's at least (min h edgeSize) checkpoints" $ \_ -> property prop_sparseCheckpointMinimum it "There's no checkpoint older than k (+/- 100)" $ \_ -> @@ -862,51 +888,51 @@ prop_rollbackTxHistory db@DBLayer{..} (InitialCheckpoint cp0) (GenTxHistory txs0 prop_sparseCheckpointTipAlwaysThere :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs (k, h)) = prop +prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs cfg (k, h)) = prop & counterexample ("Checkpoints: " <> show cps) & counterexample ("h=" <> show h) & counterexample ("k=" <> show k) where - cps = sparseCheckpoints (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity k) (Quantity h) prop :: Property prop = property $ fromIntegral h `elem` cps --- | Check that sparseCheckpoints always return at least 10 checkpoints (or --- exactly the current height if h < 10). +-- | Check that sparseCheckpoints always return at least edgeSize checkpoints (or +-- exactly the current height if h < edgeSize). prop_sparseCheckpointMinimum :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs (k, h)) = prop +prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg (k, h)) = prop & counterexample ("Checkpoints: " <> show cps) & counterexample ("h=" <> show h) & counterexample ("k=" <> show k) where - cps = sparseCheckpoints (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity k) (Quantity h) prop :: Property - prop = property $ fromIntegral (length cps) >= min 10 h + prop = property $ fromIntegral (length cps) >= min (edgeSize cfg) h -- | 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 100 blocks, it means that block #800 should be in the list. +-- checkpoints every gapsSize blocks, it means that block #800 should be in the list. -- -- Note: The initial checkpoint at #0 will always be present. prop_sparseCheckpointNoOlderThanK :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs (k, h)) = prop +prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg (k, h)) = prop & counterexample ("Checkpoints: " <> show ((\cp -> (age cp, cp)) <$> cps)) & counterexample ("h=" <> show h) & counterexample ("k=" <> show k) where - cps = sparseCheckpoints (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity k) (Quantity h) prop :: Property prop = property $ flip all cps $ \cp -> - cp == 0 || (age cp - 100 <= int k) + cp == 0 || (age cp - (int $ gapsSize cfg) <= int k) age :: Word32 -> Int age cp = int h - int cp @@ -917,12 +943,15 @@ int = fromIntegral pp :: ProtocolParameters pp = dummyProtocolParameters -newtype GenSparseCheckpointsArgs - = GenSparseCheckpointsArgs (Word32, Word32) - deriving newtype Show +data GenSparseCheckpointsArgs + = GenSparseCheckpointsArgs SparseCheckpointsConfig (Word32, Word32) + deriving Show instance Arbitrary GenSparseCheckpointsArgs where arbitrary = do k <- (\x -> 10 + (x `mod` 1000)) <$> arbitrary h <- (`mod` 100000) <$> arbitrary - pure $ GenSparseCheckpointsArgs ( k, h ) + cfg <- SparseCheckpointsConfig + <$> choose (1, k-1) + <*> choose (0, k) + pure $ GenSparseCheckpointsArgs cfg ( k, h ) From e477982f10efce7d8a73c59750cc21bbcff4701b Mon Sep 17 00:00:00 2001 From: KtorZ Date: Wed, 16 Sep 2020 16:18:38 +0200 Subject: [PATCH 2/6] add property to show that the checkpointing approach from 'restoreBlocks' is sound. --- .../test/unit/Cardano/Wallet/DB/Properties.hs | 115 +++++++++++++++++- 1 file changed, 113 insertions(+), 2 deletions(-) diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index 3bd11fedb30..953d3e2c66c 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs @@ -123,9 +123,11 @@ import Test.QuickCheck , counterexample , cover , elements + , forAll , label , property , suchThat + , (===) , (==>) ) import Test.QuickCheck.Monadic @@ -343,6 +345,12 @@ properties = do it "There's no checkpoint older than k (+/- 100)" $ \_ -> property prop_sparseCheckpointNoOlderThanK + it "All else equal, sparse checkpoints are the same for all edge size" $ \_ -> + property prop_sparseCheckpointEdgeSize0 + + it "Checkpoints are eventually stored in a sparse manner" $ \_ -> + property prop_checkpointsEventuallyEqual + -- | Wrap the result of 'readTxHistory' in an arbitrary identity Applicative readTxHistoryF :: Functor m @@ -932,11 +940,92 @@ prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg (k, h)) = prop prop :: Property prop = property $ flip all cps $ \cp -> - cp == 0 || (age cp - (int $ gapsSize cfg) <= int k) + cp == 0 || (age cp - int (gapsSize cfg) <= int k) 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 + :: GenSparseCheckpointsArgs + -> Property +prop_sparseCheckpointEdgeSize0 (GenSparseCheckpointsArgs cfg (k, h)) = prop + & counterexample ("Checkpoints: " <> show cps) + & counterexample ("h=" <> show h) + & counterexample ("k=" <> show k) + where + cps = sparseCheckpoints cfg (Quantity k) (Quantity h) + cps' = sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity k) (Quantity h) + + prop :: Property + prop = property (cps' `L.isSubsequenceOf` cps) + +-- | This property shows that, for all possible cuts (i.e. non-null batches) of +-- a sequence of blocks, the following steps: +-- +-- For all batch B in sequence: +-- +-- - Keep all checkpoints in B yielded by sparseCheckpoint with and +-- edge size of 0. +-- +-- - Keep the last checkpoint of the batch regardless +-- +-- - Prune all checkpoints not yielded by sparseCheckpoint with a non-null edge +-- size +-- +-- are equivalent to calling `sparseCheckpoints` on the flattened batch +-- sequence. +-- +-- Note that the batch creation mimics the way blocks are served by the network +-- layer to wallets: first by batches of arbitrary size, and then one by one. +-- +-- The property shows that regardless of how batches are served, after +-- 'edgeSize' one-by-one step, the end result is the same as if the entire +-- stream of blocks had been processed in one go. +prop_checkpointsEventuallyEqual + :: GenSparseCheckpointsArgs + -> Property +prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg (k,h)) = prop + & counterexample ("h=" <> show h) + & counterexample ("k=" <> show k) + where + prop :: Property + prop = forAll (genBatches args) $ \(Batches batches) -> + let + tip = + Quantity $ last $ mconcat batches + emptyDB = + SparseCheckpointsDB [] + SparseCheckpointsDB db = + L.foldr (\batch -> prune . step batch) emptyDB batches + in + db === sparseCheckpoints cfg (Quantity k) tip + + step :: [Word32] -> SparseCheckpointsDB -> SparseCheckpointsDB + step cps (SparseCheckpointsDB db) = + let + toKeep = + sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity k) (Quantity h) + cps' = + last cps : (toKeep `L.intersect` cps) + in + SparseCheckpointsDB $ L.sort $ cps' ++ db + + prune :: SparseCheckpointsDB -> SparseCheckpointsDB + prune (SparseCheckpointsDB db) = + let + tip = + Quantity $ last db + db' = + sparseCheckpoints cfg (Quantity k) tip `L.intersect` db + in + SparseCheckpointsDB db' + +newtype Batches = Batches [[Word32]] deriving Show + +newtype SparseCheckpointsDB = SparseCheckpointsDB [Word32] deriving Show + int :: Integral a => a -> Int int = fromIntegral @@ -953,5 +1042,27 @@ instance Arbitrary GenSparseCheckpointsArgs where h <- (`mod` 100000) <$> arbitrary cfg <- SparseCheckpointsConfig <$> choose (1, k-1) - <*> choose (0, k) + <*> choose (0, 10) pure $ GenSparseCheckpointsArgs cfg ( k, h ) + +-- This functions generate `h` "block header" (modeled as a Word32), grouped in +-- batches of arbitrary (albeit meaningful) sizes. +-- +-- Batches always end with `edgeSize` "block header" in singleton batches, to +-- simulate a fast and slow mode. +genBatches + :: GenSparseCheckpointsArgs + -> Gen Batches +genBatches (GenSparseCheckpointsArgs cfg (_, h)) = do + bs <- go [0..h] [] + let oneByOne = pure <$> [h+1..h+edgeSize cfg] + pure (Batches (bs ++ oneByOne)) + where + go :: [Word32] -> [[Word32]] -> Gen [[Word32]] + go [] batches = pure $ reverse batches + go source batches = 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)) + go (drop n source) (take n source : batches) From aeae316494875f15d8df939df7d8c08e1817300f Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 17 Sep 2020 12:00:07 +0200 Subject: [PATCH 3/6] make pre-conditions for sparseCheckpoints explicit in the function. Also moved the epoch stability to the 'SparseCheckpointsConfiguration' since it's mostly static --- lib/core/src/Cardano/Wallet.hs | 4 +- lib/core/src/Cardano/Wallet/DB.hs | 36 +++++++++---- lib/core/src/Cardano/Wallet/DB/Sqlite.hs | 3 +- .../test/unit/Cardano/Wallet/DB/Properties.hs | 54 +++++++++---------- 4 files changed, 55 insertions(+), 42 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 2e574773282..853311ee8b6 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -845,7 +845,7 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall liftIO $ logDelegation delegation putDelegationCertificate (PrimaryKey wid) cert slotNo - let unstable = sparseCheckpoints cfg k (nodeTip ^. #blockHeight) + let unstable = sparseCheckpoints cfg (nodeTip ^. #blockHeight) where -- NOTE -- The edge really is an optimization to avoid rolling back too @@ -860,7 +860,7 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall -- Rollback may still occur during this short period, but -- rolling back from a few hundred blocks is relatively fast -- anyway. - cfg = defaultSparseCheckpointsConfig { edgeSize = 0 } + cfg = (defaultSparseCheckpointsConfig k) { edgeSize = 0 } forM_ (NE.init cps) $ \cp' -> do let (Quantity h) = currentTip cp' ^. #blockHeight diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs index b45c04ce72f..f9d7646751e 100644 --- a/lib/core/src/Cardano/Wallet/DB.hs +++ b/lib/core/src/Cardano/Wallet/DB.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -59,10 +60,14 @@ 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 ) import Numeric.Natural ( Natural ) @@ -386,20 +391,17 @@ cleanDB DBLayer{..} = atomically $ sparseCheckpoints :: SparseCheckpointsConfig -- ^ Parameters for the function. - -> Quantity "block" Word32 - -- ^ Epoch Stability, i.e. how far we can rollback -> Quantity "block" Word32 -- ^ A given block height -> [Word32] -- ^ The list of checkpoint heights that should be kept in DB. -sparseCheckpoints cfg epochStability blkH = +sparseCheckpoints cfg blkH = let - SparseCheckpointsConfig{gapsSize,edgeSize} = cfg - k = getQuantity epochStability + SparseCheckpointsConfig{gapsSize,edgeSize,epochStability} = cfg h = getQuantity blkH minH = - let x = if h < k then 0 else h - k + let x = if h < epochStability then 0 else h - epochStability in gapsSize * (x `div` gapsSize) initial = 0 @@ -408,17 +410,31 @@ sparseCheckpoints cfg epochStability blkH = then [0..h] else [h-edgeSize,h-edgeSize+1..h] in - L.sort $ L.nub $ initial : (longTerm ++ shortTerm) + 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. data SparseCheckpointsConfig = SparseCheckpointsConfig { gapsSize :: Word32 , edgeSize :: Word32 + , epochStability :: Word32 } deriving Show -- | A sensible default to use in production. -defaultSparseCheckpointsConfig :: SparseCheckpointsConfig -defaultSparseCheckpointsConfig = SparseCheckpointsConfig - { gapsSize = 1000 +defaultSparseCheckpointsConfig :: Quantity "block" Word32 -> SparseCheckpointsConfig +defaultSparseCheckpointsConfig (Quantity k) = SparseCheckpointsConfig + { gapsSize = k `div` 3 , edgeSize = 10 + , epochStability = k } diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index 3ec80b08ce6..4e1555dc231 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -1231,7 +1231,8 @@ pruneCheckpoints pruneCheckpoints wid cp = do let height = Quantity $ fromIntegral $ checkpointBlockHeight cp let epochStability = Quantity $ checkpointEpochStability cp - let cps = sparseCheckpoints defaultSparseCheckpointsConfig epochStability height + let cfg = defaultSparseCheckpointsConfig epochStability + let cps = sparseCheckpoints cfg height deleteCheckpoints wid [ CheckpointBlockHeight /<-. cps ] -- | Delete TxMeta values for a wallet. diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index 953d3e2c66c..4629d2135f7 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs @@ -295,23 +295,23 @@ properties = do let cfg = SparseCheckpointsConfig { gapsSize = 100 , edgeSize = 10 + , epochStability = 2160 } - let k = Quantity 2160 let h = Quantity 42 -- First unstable block: 0 - sparseCheckpoints cfg k h `shouldBe` + sparseCheckpoints cfg h `shouldBe` [0,32,33,34,35,36,37,38,39,40,41,42] it "k=2160, h=2414" $ \_ -> do let cfg = SparseCheckpointsConfig { gapsSize = 100 , edgeSize = 10 + , epochStability = 2160 } - let k = Quantity 2160 let h = Quantity 2714 -- First unstable block: 554 - sparseCheckpoints cfg k h `shouldBe` + sparseCheckpoints cfg h `shouldBe` [ 0 , 500 , 600 , 700 , 800 , 900 , 1000 , 1100 , 1200 , 1300 , 1400 , 1500 , 1600 , 1700 , 1800 , 1900 , 2000 , 2100 @@ -324,11 +324,11 @@ properties = do let cfg = SparseCheckpointsConfig { gapsSize = 100 , edgeSize = 0 + , epochStability = 2160 } - let k = Quantity 2160 let h = Quantity 2714 -- First unstable block: 554 - sparseCheckpoints cfg k h `shouldBe` + sparseCheckpoints cfg h `shouldBe` [ 0 , 500 , 600 , 700 , 800 , 900 , 1000 , 1100 , 1200 , 1300 , 1400 , 1500 , 1600 , 1700 , 1800 , 1900 , 2000 , 2100 @@ -345,7 +345,7 @@ properties = do it "There's no checkpoint older than k (+/- 100)" $ \_ -> property prop_sparseCheckpointNoOlderThanK - it "All else equal, sparse checkpoints are the same for all edge size" $ \_ -> + it "∀ cfg. sparseCheckpoints (cfg { edgeSize = 0 }) ⊆ sparseCheckpoints cfg" $ \_ -> property prop_sparseCheckpointEdgeSize0 it "Checkpoints are eventually stored in a sparse manner" $ \_ -> @@ -896,12 +896,11 @@ prop_rollbackTxHistory db@DBLayer{..} (InitialCheckpoint cp0) (GenTxHistory txs0 prop_sparseCheckpointTipAlwaysThere :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs cfg (k, h)) = prop +prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs cfg h) = prop & counterexample ("Checkpoints: " <> show cps) & counterexample ("h=" <> show h) - & counterexample ("k=" <> show k) where - cps = sparseCheckpoints cfg (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity h) prop :: Property prop = property $ fromIntegral h `elem` cps @@ -911,12 +910,11 @@ prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs cfg (k, h)) = prop prop_sparseCheckpointMinimum :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg (k, h)) = prop +prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg h) = prop & counterexample ("Checkpoints: " <> show cps) & counterexample ("h=" <> show h) - & counterexample ("k=" <> show k) where - cps = sparseCheckpoints cfg (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity h) prop :: Property prop = property $ fromIntegral (length cps) >= min (edgeSize cfg) h @@ -931,16 +929,15 @@ prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg (k, h)) = prop prop_sparseCheckpointNoOlderThanK :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg (k, h)) = prop +prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg h) = prop & counterexample ("Checkpoints: " <> show ((\cp -> (age cp, cp)) <$> cps)) & counterexample ("h=" <> show h) - & counterexample ("k=" <> show k) where - cps = sparseCheckpoints cfg (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity h) prop :: Property prop = property $ flip all cps $ \cp -> - cp == 0 || (age cp - int (gapsSize cfg) <= int k) + cp == 0 || (age cp - int (gapsSize cfg) <= int (epochStability cfg)) age :: Word32 -> Int age cp = int h - int cp @@ -950,13 +947,12 @@ prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg (k, h)) = prop prop_sparseCheckpointEdgeSize0 :: GenSparseCheckpointsArgs -> Property -prop_sparseCheckpointEdgeSize0 (GenSparseCheckpointsArgs cfg (k, h)) = prop +prop_sparseCheckpointEdgeSize0 (GenSparseCheckpointsArgs cfg h) = prop & counterexample ("Checkpoints: " <> show cps) & counterexample ("h=" <> show h) - & counterexample ("k=" <> show k) where - cps = sparseCheckpoints cfg (Quantity k) (Quantity h) - cps' = sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity k) (Quantity h) + cps = sparseCheckpoints cfg (Quantity h) + cps' = sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity h) prop :: Property prop = property (cps' `L.isSubsequenceOf` cps) @@ -986,9 +982,8 @@ prop_sparseCheckpointEdgeSize0 (GenSparseCheckpointsArgs cfg (k, h)) = prop prop_checkpointsEventuallyEqual :: GenSparseCheckpointsArgs -> Property -prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg (k,h)) = prop +prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg h) = prop & counterexample ("h=" <> show h) - & counterexample ("k=" <> show k) where prop :: Property prop = forAll (genBatches args) $ \(Batches batches) -> @@ -1000,13 +995,13 @@ prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg (k,h)) = prop SparseCheckpointsDB db = L.foldr (\batch -> prune . step batch) emptyDB batches in - db === sparseCheckpoints cfg (Quantity k) tip + db === sparseCheckpoints cfg tip step :: [Word32] -> SparseCheckpointsDB -> SparseCheckpointsDB step cps (SparseCheckpointsDB db) = let toKeep = - sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity k) (Quantity h) + sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity h) cps' = last cps : (toKeep `L.intersect` cps) in @@ -1018,7 +1013,7 @@ prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg (k,h)) = prop tip = Quantity $ last db db' = - sparseCheckpoints cfg (Quantity k) tip `L.intersect` db + sparseCheckpoints cfg tip `L.intersect` db in SparseCheckpointsDB db' @@ -1033,7 +1028,7 @@ pp :: ProtocolParameters pp = dummyProtocolParameters data GenSparseCheckpointsArgs - = GenSparseCheckpointsArgs SparseCheckpointsConfig (Word32, Word32) + = GenSparseCheckpointsArgs SparseCheckpointsConfig Word32 deriving Show instance Arbitrary GenSparseCheckpointsArgs where @@ -1043,7 +1038,8 @@ instance Arbitrary GenSparseCheckpointsArgs where cfg <- SparseCheckpointsConfig <$> choose (1, k-1) <*> choose (0, 10) - pure $ GenSparseCheckpointsArgs cfg ( k, h ) + <*> pure k + pure $ GenSparseCheckpointsArgs cfg h -- This functions generate `h` "block header" (modeled as a Word32), grouped in -- batches of arbitrary (albeit meaningful) sizes. @@ -1053,7 +1049,7 @@ instance Arbitrary GenSparseCheckpointsArgs where genBatches :: GenSparseCheckpointsArgs -> Gen Batches -genBatches (GenSparseCheckpointsArgs cfg (_, h)) = do +genBatches (GenSparseCheckpointsArgs cfg h) = do bs <- go [0..h] [] let oneByOne = pure <$> [h+1..h+edgeSize cfg] pure (Batches (bs ++ oneByOne)) From 9b5318061af068882b30a874e4912dd6897cb61a Mon Sep 17 00:00:00 2001 From: KtorZ Date: Thu, 17 Sep 2020 16:06:49 +0200 Subject: [PATCH 4/6] 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 | 71 +++++++++++-------- .../test/unit/Cardano/Wallet/DB/Properties.hs | 68 ++++++++++-------- 2 files changed, 78 insertions(+), 61 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs index f9d7646751e..091d6ab8fee 100644 --- a/lib/core/src/Cardano/Wallet/DB.hs +++ b/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 diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index 4629d2135f7..c75b9e77e14 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/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,19 +918,25 @@ 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 @@ -937,11 +944,12 @@ prop_sparseCheckpointNoOlderThanK (GenSparseCheckpointsArgs cfg h) = prop 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) From 5333899ccd425e34b1ff98b5ce18e4f8178ccc21 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 18 Sep 2020 15:37:58 +0200 Subject: [PATCH 5/6] add property to show that we can *never* rollback more than a given known acceptable limit What we show is that, assuming when the longest chain switch possible is of length k, the wallet will never need to reapply more than k + gapSize blocks, where gapSize is strictly smaller than k. So, this gives the guarantee that we'll never have to re-apply more than 2k blocks in worse scenarios which seems very acceptable. --- lib/core/src/Cardano/Wallet/DB.hs | 2 +- .../test/unit/Cardano/Wallet/DB/Properties.hs | 85 +++++++++---------- 2 files changed, 43 insertions(+), 44 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs index 091d6ab8fee..95a57de4bfc 100644 --- a/lib/core/src/Cardano/Wallet/DB.hs +++ b/lib/core/src/Cardano/Wallet/DB.hs @@ -400,7 +400,7 @@ sparseCheckpoints cfg blkH = e = fromIntegral edgeSize minH = - let x = if h < epochStability then 0 else h - epochStability + let x = if h < epochStability + g then 0 else h - epochStability - g in g * (x `div` g) initial = 0 diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index c75b9e77e14..84884ab9694 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs @@ -121,6 +121,7 @@ import Test.QuickCheck , Property , checkCoverage , choose + , conjoin , counterexample , cover , elements @@ -128,6 +129,7 @@ import Test.QuickCheck , label , property , suchThat + , (.&&.) , (===) , (==>) ) @@ -343,9 +345,6 @@ properties = do it "There's at least (min h edgeSize) checkpoints" $ \_ -> property prop_sparseCheckpointMinimum - it "There's no checkpoint older than k (+/- 100)" $ \_ -> - property prop_sparseCheckpointNoOlderThanK - it "∀ cfg. sparseCheckpoints (cfg { edgeSize = 0 }) ⊆ sparseCheckpoints cfg" $ \_ -> property prop_sparseCheckpointEdgeSize0 @@ -922,34 +921,6 @@ prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg h) = prop 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 gapSize blocks, it means that block #800 should be in the list. --- --- 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) = - (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 (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 @@ -990,20 +961,51 @@ prop_sparseCheckpointEdgeSize0 (GenSparseCheckpointsArgs cfg h) = prop prop_checkpointsEventuallyEqual :: GenSparseCheckpointsArgs -> Property -prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg h) = prop - & counterexample ("h=" <> show h) - where - prop :: Property - prop = forAll (genBatches args) $ \(Batches batches) -> +prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg h) = + h > epochStability cfg ==> forAll (genBatches args) $ \(Batches batches) -> let tip = Quantity $ last $ mconcat batches emptyDB = SparseCheckpointsDB [] - SparseCheckpointsDB db = - L.foldr (\batch -> prune . step batch) emptyDB batches + dbs = + L.scanl (\db batch -> prune $ step batch db) emptyDB batches in - db === sparseCheckpoints cfg tip + ( prop_eventuallyReachesExpectedTip tip dbs + .&&. + prop_canNeverRollbackMoreThanKPlusGap tip dbs + ) + where + prop_eventuallyReachesExpectedTip + :: Quantity "block" Word32 + -> [SparseCheckpointsDB] + -> Property + prop_eventuallyReachesExpectedTip tip dbs = + last dbs === SparseCheckpointsDB (sparseCheckpoints cfg tip) + + prop_canNeverRollbackMoreThanKPlusGap + :: Quantity "block" Word32 + -> [SparseCheckpointsDB] + -> Property + prop_canNeverRollbackMoreThanKPlusGap (Quantity tip) dbs = + conjoin (forEachStep <$> L.tail dbs) + where + forEachStep (SparseCheckpointsDB db) = + let + -- db' contains all the _stable checkpoints_ in the database, + -- i.e. those that are in the interval [0; network tip - k) + -- + -- So, if we are asked to rollback for a full k, we'll end up + -- rolling back to the closest checkpoint from that interval. + db' = filter (< (tip - epochStability cfg)) db + farthestRollback = last db - last db' + in + property + (farthestRollback <= epochStability cfg + gapSize cfg) + & counterexample + ("database: " <> show db) + & counterexample + ("stable checkpoints: " <> show db') step :: [Word32] -> SparseCheckpointsDB -> SparseCheckpointsDB step cps (SparseCheckpointsDB db) = @@ -1027,10 +1029,7 @@ prop_checkpointsEventuallyEqual args@(GenSparseCheckpointsArgs cfg h) = prop newtype Batches = Batches [[Word32]] deriving Show -newtype SparseCheckpointsDB = SparseCheckpointsDB [Word32] deriving Show - -int :: Integral a => a -> Int -int = fromIntegral +newtype SparseCheckpointsDB = SparseCheckpointsDB [Word32] deriving (Show, Eq) pp :: ProtocolParameters pp = dummyProtocolParameters From 4cb977e45ab3fdfa027e0fa39bd26b444bc56335 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Fri, 18 Sep 2020 16:00:43 +0200 Subject: [PATCH 6/6] increase timeout for Shelley estimateMaxNumberOfInputs properties This timeout is truly to check that the function doesn't blow up and stay within 'acceptable' bound. It fails to pass on some machine in CI, so increasing it a bit but within the same order of magnitude. --- .../test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs index cd6ff743fc1..0f8ed766477 100644 --- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs +++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs @@ -262,7 +262,7 @@ prop_moreOutputsMeansLessInputs -> Property prop_moreOutputsMeansLessInputs net size nOuts = withMaxSuccess 1000 - $ within 100000 + $ within 300000 $ nOuts < maxBound ==> _estimateMaxNumberOfInputs @k net size Nothing nOuts >= @@ -277,7 +277,7 @@ prop_lessOutputsMeansMoreInputs -> Property prop_lessOutputsMeansMoreInputs net size nOuts = withMaxSuccess 1000 - $ within 100000 + $ within 300000 $ nOuts > minBound ==> _estimateMaxNumberOfInputs @k net size Nothing (nOuts - 1) >= @@ -292,7 +292,7 @@ prop_biggerMaxSizeMeansMoreInputs -> Property prop_biggerMaxSizeMeansMoreInputs net (Quantity size) nOuts = withMaxSuccess 1000 - $ within 100000 + $ within 300000 $ size < maxBound `div` 2 ==> _estimateMaxNumberOfInputs @k net (Quantity size) Nothing nOuts <=