Skip to content

Commit

Permalink
make pre-conditions for sparseCheckpoints explicit in the function.
Browse files Browse the repository at this point in the history
  Also moved the epoch stability to the 'SparseCheckpointsConfiguration' since it's mostly static
  • Loading branch information
KtorZ committed Sep 17, 2020
1 parent e477982 commit aeae316
Show file tree
Hide file tree
Showing 4 changed files with 55 additions and 42 deletions.
4 changes: 2 additions & 2 deletions lib/core/src/Cardano/Wallet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
36 changes: 26 additions & 10 deletions lib/core/src/Cardano/Wallet/DB.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
Expand Down Expand Up @@ -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 )

Expand Down Expand Up @@ -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
Expand All @@ -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
}
3 changes: 2 additions & 1 deletion lib/core/src/Cardano/Wallet/DB/Sqlite.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
54 changes: 25 additions & 29 deletions lib/core/test/unit/Cardano/Wallet/DB/Properties.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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" $ \_ ->
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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) ->
Expand All @@ -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
Expand All @@ -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'

Expand All @@ -1033,7 +1028,7 @@ pp :: ProtocolParameters
pp = dummyProtocolParameters

data GenSparseCheckpointsArgs
= GenSparseCheckpointsArgs SparseCheckpointsConfig (Word32, Word32)
= GenSparseCheckpointsArgs SparseCheckpointsConfig Word32
deriving Show

instance Arbitrary GenSparseCheckpointsArgs where
Expand All @@ -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.
Expand All @@ -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))
Expand Down

0 comments on commit aeae316

Please sign in to comment.