diff --git a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs index 69e1b9deeed..d1292d746c7 100644 --- a/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs +++ b/lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs @@ -138,8 +138,6 @@ import Data.Function ( (&) ) import Data.Generics.Internal.VL.Lens ( view, (^.) ) -import Data.Generics.Wrapped - ( _Unwrapped ) import Data.Maybe ( fromJust, isJust ) import Data.Proxy @@ -2644,8 +2642,16 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do dest <- emptyWallet ctx let depositAmt = Quantity 1_000_000 - pool1:pool2:_ <- map (view $ _Unwrapped . #id) . snd <$> unsafeRequest @[ApiT StakePool] - ctx (Link.listStakePools arbitraryStake) Empty + -- Note: In the local cluster, some of the pools retire early. + -- When running the test in isolation, we have to delegate + -- to pools which will retire later. + let won'tRetire pool' = case pool' ^. #retirement of + Nothing -> True + Just epoch -> epoch ^. #epochNumber >= 100 + pools <- filter won'tRetire . map getApiT . snd <$> + unsafeRequest @[ApiT StakePool] ctx + (Link.listStakePools arbitraryStake) Empty + let pool1:pool2:_ = map (view #id) pools let delegationJoin = Json [json|{ "delegations": [{ @@ -2891,28 +2897,29 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do , expectResponseCode HTTP.status202 ] - let txid3 = getFromResponse (#id) submittedTx4 - let queryTx3 = Link.getTransaction @'Shelley src (ApiTxId txid3) - rGetTx3 <- request @(ApiTransaction n) ctx queryTx3 Default Empty - verify rGetTx3 - [ expectResponseCode HTTP.status200 - , expectField #depositTaken (`shouldBe` Quantity 0) - , expectField #depositReturned (`shouldBe` depositAmt) - ] - - eventually "Wallet is not delegating" $ do - request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty - >>= flip verify - [ expectField #delegation (`shouldBe` notDelegating []) - ] + -- Wait for the transaction to be accepted into the ledger + let txidQuit = getFromResponse (#id) submittedTx4 + queryTxQuit = Link.getTransaction @'Shelley src (ApiTxId txidQuit) + eventually "Wait for ledger to accept Quit transaction" $ do + rGetTxQuit <- request @(ApiTransaction n) ctx queryTxQuit Default Empty + verify rGetTxQuit + [ expectResponseCode HTTP.status200 + , expectField #insertedAt (`shouldSatisfy` isJust) + ] - -- transaction history shows deposit returned - rGetTx4 <- request @(ApiTransaction n) ctx queryTx3 Default Empty - verify rGetTx4 + -- Wallet will stop delegating + rGetTxQuit' <- request @(ApiTransaction n) ctx queryTxQuit Default Empty + verify rGetTxQuit' [ expectResponseCode HTTP.status200 , expectField #depositTaken (`shouldBe` Quantity 0) , expectField #depositReturned (`shouldBe` depositAmt) ] + eventually "Wallet not delegating" $ do + rGetQuit <- request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty + verify rGetQuit + [ expectResponseCode HTTP.status200 + , expectField #delegation (`shouldBe` notDelegating []) + ] it "TRANS_NEW_JOIN_01b - Invalid pool id" $ \ctx -> runResourceT $ do wa <- fixtureWallet ctx diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs index 4a966d4b2a1..e5145151b12 100644 --- a/lib/wallet/src/Cardano/Wallet.hs +++ b/lib/wallet/src/Cardano/Wallet.hs @@ -330,7 +330,9 @@ import Cardano.Wallet.Address.Keys.WalletKey import Cardano.Wallet.Address.States.IsOwned ( isOwned ) import Cardano.Wallet.Checkpoints - ( DeltaCheckpoints (..), extendCheckpoints, pruneCheckpoints ) + ( DeltaCheckpoints (..), extendAndPrune ) +import Cardano.Wallet.Checkpoints.Policy + ( sparseArithmetic ) import Cardano.Wallet.DB ( DBFresh (..) , DBLayer (..) @@ -355,6 +357,7 @@ import Cardano.Wallet.DB.WalletState , DeltaWalletState1 (..) , WalletState (..) , fromWallet + , getBlockHeight , getLatest , getSlot ) @@ -1219,22 +1222,19 @@ restoreBlocks ctx tr blocks nodeTip = db & \DBLayer{..} -> atomically $ do let finalitySlot = nodeTip ^. #slotNo - stabilityWindowShelley slottingParams - -- Checkpoint deltas let wcps = snd . fromWallet <$> cps - deltaPutCheckpoints = - extendCheckpoints + epochStability' = fromIntegral $ getQuantity epochStability + deltaCheckpoints wallet = + extendAndPrune getSlot - (view $ #currentTip . #blockHeight) - epochStability - (nodeTip ^. #blockHeight) + (fromIntegral . getBlockHeight) + (sparseArithmetic epochStability') + (fromIntegral $ getQuantity $ localTip ^. #blockHeight) + -- nodeTip instead of localTip should work as well, + -- but for some reason, the integration tests + -- become flakier. wcps - - deltaPruneCheckpoints wallet = - pruneCheckpoints - (view $ #currentTip . #blockHeight) - epochStability - (localTip ^. #blockHeight) - (wallet ^. #checkpoints) + (checkpoints wallet) let -- NOTE: We have to update the 'Prologue' as well, @@ -1263,14 +1263,11 @@ restoreBlocks ctx tr blocks nodeTip = db & \DBLayer{..} -> atomically $ do liftIO $ logDelegation delegation putDelegationCertificate walletState cert slotNo - Delta.onDBVar walletState $ Delta.update $ \_wallet -> + Delta.onDBVar walletState $ Delta.update $ \wallet -> deltaPrologue - <> [ UpdateCheckpoints deltaPutCheckpoints ] + <> [ UpdateCheckpoints $ deltaCheckpoints wallet ] <> deltaPruneSubmissions - Delta.onDBVar walletState $ Delta.update $ \wallet -> - [ UpdateCheckpoints $ deltaPruneCheckpoints wallet ] - liftIO $ do traceWith tr $ MsgDiscoveredTxs txs traceWith tr $ MsgDiscoveredTxsContent txs diff --git a/lib/wallet/src/Cardano/Wallet/Checkpoints.hs b/lib/wallet/src/Cardano/Wallet/Checkpoints.hs index 1fe7fd6e05b..f77aacbf690 100644 --- a/lib/wallet/src/Cardano/Wallet/Checkpoints.hs +++ b/lib/wallet/src/Cardano/Wallet/Checkpoints.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE TypeFamilies #-} @@ -26,18 +25,14 @@ module Cardano.Wallet.Checkpoints -- * Checkpoint hygiene , BlockHeight - , extendCheckpoints - , pruneCheckpoints - - -- * Checkpoint creation - , SparseCheckpointsConfig (..) - , defaultSparseCheckpointsConfig - , sparseCheckpoints - , gapSize + , CheckpointPolicy + , extendAndPrune ) where import Prelude +import Cardano.Wallet.Checkpoints.Policy + ( BlockHeight, CheckpointPolicy, keepWhereTip ) import Data.Delta ( Delta (..) ) import Data.Generics.Internal.VL.Lens @@ -46,17 +41,12 @@ 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.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -159,195 +149,50 @@ instance Buildable (DeltaCheckpoints a) where {------------------------------------------------------------------------------- Checkpoint hygiene -------------------------------------------------------------------------------} -type BlockHeight = Quantity "block" Word32 -{- Note [Checkpoints-SummaryVsList] +{- Note [extendAndPrune] -The 'extendCheckpoints' is designed for the case where the blocks are -given as a 'List', not as a 'Summary'. -In this 'Summary' case, it could happen that the current -scheme fails to create sufficiently many checkpoint as -it was never able to touch the corresponding block. +The function 'extendAndPrune' expects a list of new checkpoints that +are to be pruned and added to the existing checkpoints. -For now, we avoid this situation by being always supplied a 'List' -in the unstable region close to the tip. - -Another solution is to use 'nextCheckpoint' from the -'CheckpointPolicy' in order to drive the checkpoint collection in 'Summary'. +As a precondition, we assume that these new checkpoints +have been created at least at those block heights +specified by 'nextCheckpoint' from the 'CheckpointPolicy' argument. +Except for the most recent checkpoint, +the function 'extendAndPrune' will prune all checkpoints +whose block height does not align with the policy. +It's ok to supply a list of new checkpoints that is denser than required. -} --- | Extend the known checkpoints. -extendCheckpoints +-- | Extend the known checkpoints and prune unnecessary ones. +extendAndPrune :: (a -> W.Slot) -- ^ Convert checkpoint to slot. -> (a -> BlockHeight) -- ^ Convert checkpoint to block height. - -> BlockHeight - -- ^ Epoch stability window = length of the deepest rollback. + -> CheckpointPolicy + -- ^ Policy to use for pruning checkpoints. -> BlockHeight -- ^ Current tip of the blockchain, -- which is *different* from block height of the latest checkpoint. -> NE.NonEmpty a -- ^ New checkpoints, ordered by increasing @Slot@. - -> DeltasCheckpoints a -extendCheckpoints getSlot getBlockHeight epochStability nodeTip cps = - reverse - [ PutCheckpoint (getSlot wcp) wcp - | wcp <- cpsKeep - ] - where - unstable = Set.map Quantity $ Set.fromList $ sparseCheckpoints cfg nodeTip - 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 epochStability) { edgeSize = 0 } - willKeep cp = getBlockHeight cp `Set.member` unstable - cpsKeep = filter willKeep (NE.init cps) <> [NE.last cps] - --- | Compute a delta to prune the 'Checkpoints' --- according to 'defaultSparseCheckpointsConfig'. -pruneCheckpoints - :: (a -> BlockHeight) - -- ^ Retrieve 'BlockHeight' from checkpoint data. - -> BlockHeight - -- ^ Epoch stability window = length of the deepest rollback. - -> BlockHeight - -- ^ Block height of the latest checkpoint. + -- See Note [extendAndPrune]. -> Checkpoints a + -- ^ Current checkpoints. -> DeltasCheckpoints a -pruneCheckpoints getHeight epochStability tip (Checkpoints cps) = - [ RestrictTo slots ] +extendAndPrune getSlot getHeight policy nodeTip xs (Checkpoints cps) = + additions <> pruneOld where - willKeep cp = getQuantity (getHeight cp) `Set.member` heights - slots = Map.keys $ Map.filter willKeep cps - heights = Set.fromList $ sparseCheckpoints - (defaultSparseCheckpointsConfig epochStability) - tip + additions = reverse -- latest slot needs to be applied last + [ PutCheckpoint (getSlot x) x | x <- new ] + pruneOld = [ RestrictTo $ map getSlot old ] -{------------------------------------------------------------------------------- - Checkpoint creation --------------------------------------------------------------------------------} --- | 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 deep ones --- --- 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 switched 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. - -> BlockHeight - -- ^ 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 each a few blocks deep 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 :: BlockHeight -> 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 + new = filter willKeep (NE.toList xs) + old = filter willKeep (Map.elems cps) + + latest = NE.last xs + isLatest x = getHeight x == getHeight latest + + willKeep x = isLatest x || keepWhereTip policy (getHeight x) nodeTip + -- We must keep the most recent checkpoint or nothing will be extended diff --git a/lib/wallet/test/unit/Cardano/Wallet/Checkpoints/PolicySpec.hs b/lib/wallet/test/unit/Cardano/Wallet/Checkpoints/PolicySpec.hs index 34ba2ac911f..a99ea42f3b2 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/Checkpoints/PolicySpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/Checkpoints/PolicySpec.hs @@ -6,7 +6,12 @@ module Cardano.Wallet.Checkpoints.PolicySpec import Prelude import Cardano.Wallet.Checkpoints.Policy - ( BlockHeight, CheckpointPolicy, nextCheckpoint, toListAtTip ) + ( BlockHeight + , CheckpointPolicy + , keepWhereTip + , nextCheckpoint + , toListAtTip + ) import Test.Hspec ( Spec, describe, it ) import Test.QuickCheck @@ -60,6 +65,10 @@ spec = do it "trailingArithmetic checkpoints are located at grid points" $ property prop_trailingGrid + it "sparseArithmetic has genesis" $ + property $ \(GenHeightContext epochStability tip) -> + keepWhereTip (CP.sparseArithmetic epochStability) tip 0 + it "sparseArithmetic checkpoints after genesis are close to tip" $ property $ \(GenHeightContext epochStability tip) -> maybe False (>= tip - 2*epochStability - 20) $ diff --git a/lib/wallet/test/unit/Cardano/Wallet/CheckpointsSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/CheckpointsSpec.hs index 147d7e12ef0..00c942e2a98 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/CheckpointsSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/CheckpointsSpec.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Wallet.CheckpointsSpec ( spec ) where @@ -6,263 +8,113 @@ module Cardano.Wallet.CheckpointsSpec import Prelude import Cardano.Wallet.Checkpoints - ( SparseCheckpointsConfig (..), gapSize, sparseCheckpoints ) -import Data.Function - ( (&) ) -import Data.Quantity - ( Quantity (..) ) -import Data.Word - ( Word32 ) + ( Checkpoints + , DeltaCheckpoints (..) + , checkpoints + , extendAndPrune + , fromGenesis + , getLatest + , loadCheckpoints + ) +import Cardano.Wallet.Checkpoints.Policy + ( sparseArithmetic ) +import Cardano.Wallet.Gen + ( genSlotNo ) +import Cardano.Wallet.Primitive.Types + ( Slot, SlotNo (..), WithOrigin (..) ) +import Data.Delta + ( Delta (..) ) import Test.Hspec - ( Spec, describe, it, shouldBe ) + ( Spec, describe, it ) import Test.QuickCheck ( Arbitrary (..) - , Gen , Property , choose - , conjoin - , counterexample , forAll + , frequency + , getPositive + , listOf , property - , (.&&.) , (===) - , (==>) ) -import qualified Data.List as L - +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map spec :: Spec spec = do - describe "sparseCheckpoints" $ do - it "k=2160, h=42" $ \_ -> do - let cfg = SparseCheckpointsConfig - { 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 -- Short-term checkpoints - , 42 -- Tip - ] - - it "k=2160, h=2414" $ \_ -> do - let cfg = SparseCheckpointsConfig - { edgeSize = 10 - , epochStability = 2160 - } - let h = Quantity 2714 - -- First unstable block: 554 - sparseCheckpoints cfg h `shouldBe` - [ 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 - { edgeSize = 0 - , epochStability = 2160 - } - let h = Quantity 2714 - -- First unstable block: 554 - sparseCheckpoints cfg h `shouldBe` - [ 0 - , 720, 1440, 2160 -- Long-term checkpoints - , 2714 -- Tip - ] - - it "The tip is always a checkpoint" $ \_ -> - property prop_sparseCheckpointTipAlwaysThere - - it "There's at least (min h edgeSize) checkpoints" $ \_ -> - property prop_sparseCheckpointMinimum - - it "∀ cfg. sparseCheckpoints (cfg { edgeSize = 0 }) ⊆ sparseCheckpoints cfg" $ \_ -> - property prop_sparseCheckpointEdgeSize0 - - it "Checkpoints are eventually stored in a sparse manner" $ \_ -> - property prop_checkpointsEventuallyEqual + describe "extendAndPrune" $ do + it "actually prunes checkpoints" $ + property prop_doesPrune + it "keeps the tip of the chain" $ + property prop_keepTip {------------------------------------------------------------------------------- - Checkpoint hygiene + Properties of extendAndPrune -------------------------------------------------------------------------------} --- | No matter what, the current tip is always a checkpoint. -prop_sparseCheckpointTipAlwaysThere - :: GenSparseCheckpointsArgs - -> Property -prop_sparseCheckpointTipAlwaysThere (GenSparseCheckpointsArgs cfg h) = prop - & counterexample ("Checkpoints: " <> show cps) - & counterexample ("h=" <> show h) +prop_doesPrune :: Property +prop_doesPrune = + forAll (choose (10,100)) $ \n -> + forAll (choose (10,1000)) $ \tip -> + let cps0 = denseCheckpoints n + m = size cps0 + in m > size (testExtendAndPrune tip 1 cps0) + +prop_keepTip :: Checkpoints MockCheckpoint -> Property +prop_keepTip cps0 = + (tipHeight + m + 1) + === snd (snd $ getLatest $ testExtendAndPrune tipHeight m cps0) where - cps = sparseCheckpoints cfg (Quantity h) + m = 2 + tipHeight = snd . snd $ getLatest cps0 - prop :: Property - prop = property $ fromIntegral h `elem` cps +{------------------------------------------------------------------------------- + Helper functions and generators +-------------------------------------------------------------------------------} +type MockCheckpoint = (Slot, Integer) --- | Check that sparseCheckpoints always return at least edgeSize checkpoints (or --- exactly the current height if h < edgeSize). -prop_sparseCheckpointMinimum - :: GenSparseCheckpointsArgs - -> Property -prop_sparseCheckpointMinimum (GenSparseCheckpointsArgs cfg h) = prop - & counterexample ("Checkpoints: " <> show cps) - & counterexample ("h=" <> show h) - where - cps = sparseCheckpoints cfg (Quantity h) +instance Arbitrary Slot where + arbitrary = frequency + [ (1, pure Origin) + , (20, At <$> genSlotNo) + ] - prop :: Property - prop = property $ fromIntegral (length cps) >= min e h +instance Arbitrary (Checkpoints MockCheckpoint) where + arbitrary = do + xs <- listOf (getPositive <$> arbitrary) + pure $ loadCheckpoints $ map expand + $ (Origin,0): map mkMockCheckpoint xs where - e = fromIntegral $ edgeSize cfg - --- | 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 h) = prop - & counterexample ("Checkpoints: " <> show cps) - & counterexample ("h=" <> show h) + expand (slot,j) = (slot, (slot,j)) + +size :: Checkpoints a -> Integer +size = fromIntegral . Map.size . checkpoints + +-- | Specialized version of 'extendAndPrune' for testing. +testExtendAndPrune + :: Integer + -> Integer + -> Checkpoints MockCheckpoint + -> Checkpoints MockCheckpoint +testExtendAndPrune tip n cps = + apply (extendAndPrune fst snd policy tip nexts cps) cps where - cps = sparseCheckpoints cfg (Quantity h) - cps' = sparseCheckpoints (cfg { edgeSize = 0 }) (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 h) = - h > epochStability cfg ==> forAll (genBatches args) $ \(Batches batches) -> - let - tip = - Quantity $ last $ mconcat batches - emptyDB = - SparseCheckpointsDB [] - dbs = - L.scanl (\db batch -> prune $ step batch db) emptyDB batches - in - ( 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') + next = snd (snd (getLatest cps)) + 1 + nexts = NE.fromList $ mkSlotRange next (next + n) + policy = sparseArithmetic 20 - step :: [Word32] -> SparseCheckpointsDB -> SparseCheckpointsDB - step cps (SparseCheckpointsDB db) = - let - toKeep = - sparseCheckpoints (cfg { edgeSize = 0 }) (Quantity h) - cps' = - last cps : (toKeep `L.intersect` cps) - in - SparseCheckpointsDB $ L.sort $ cps' ++ db +-- | Generate a range of slots. +mkSlotRange :: Integer -> Integer -> [MockCheckpoint] +mkSlotRange a b = map mkMockCheckpoint [a..b] - prune :: SparseCheckpointsDB -> SparseCheckpointsDB - prune (SparseCheckpointsDB db) = - let - tip = - Quantity $ last db - db' = - sparseCheckpoints cfg tip `L.intersect` db - in - SparseCheckpointsDB db' +mkMockCheckpoint :: Integer -> MockCheckpoint +mkMockCheckpoint j = (At (slotNo j), fromIntegral j) -newtype Batches = Batches [[Word32]] deriving Show - -newtype SparseCheckpointsDB = SparseCheckpointsDB [Word32] deriving (Show, Eq) - -data GenSparseCheckpointsArgs - = GenSparseCheckpointsArgs SparseCheckpointsConfig Word32 - deriving Show - -instance Arbitrary GenSparseCheckpointsArgs where - arbitrary = do - k <- (\x -> 10 + (x `mod` 1000)) <$> arbitrary - 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 --- 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 e = fromIntegral $ edgeSize cfg - let oneByOne = pure <$> [h+1..h+e] - pure (Batches (bs ++ oneByOne)) +-- | Dense collection of checkpoints. +denseCheckpoints :: Integer -> Checkpoints MockCheckpoint +denseCheckpoints n = apply deltas $ fromGenesis (Origin,0) 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 <- fromIntegral <$> choose (1, 3 * gapSize cfg) - go (drop n source) (take n source : batches) + deltas = [ PutCheckpoint slot (slot,j) | (slot,j) <- mkSlotRange 1 (n-1) ] + +slotNo :: Integer -> SlotNo +slotNo = SlotNo . fromIntegral diff --git a/lib/wallet/test/unit/Cardano/Wallet/DB/LayerSpec.hs b/lib/wallet/test/unit/Cardano/Wallet/DB/LayerSpec.hs index 2cfbc35c9a3..f4506abf9b3 100644 --- a/lib/wallet/test/unit/Cardano/Wallet/DB/LayerSpec.hs +++ b/lib/wallet/test/unit/Cardano/Wallet/DB/LayerSpec.hs @@ -259,6 +259,7 @@ import UnliftIO.Temporary import qualified Cardano.Wallet.Address.Derivation.Shelley as Seq import qualified Cardano.Wallet.Checkpoints as Checkpoints +import qualified Cardano.Wallet.Checkpoints.Policy as Checkpoints import qualified Cardano.Wallet.DB.Sqlite.Schema as DB import qualified Cardano.Wallet.DB.Sqlite.Types as DB import qualified Cardano.Wallet.DB.Store.Info.Store as WalletInfo @@ -269,6 +270,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.Delta.Update as Delta import qualified Data.List as L +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -569,28 +571,27 @@ fileModeSpec = do mempty let (FilteredBlock{transactions=txs}, (_,cpB)) = applyBlock fakeBlock cpA - epochStability = Quantity 2160 - deltaPruneCheckpoints = - Checkpoints.pruneCheckpoints - (view $ #currentTip . #blockHeight) - epochStability - (currentTip cpB ^. #blockHeight) - let putCheckpoint cp = + epochStability = 2160 + deltaPruneCheckpoints cp nodeTip = + Checkpoints.extendAndPrune + WalletState.getSlot + (fromIntegral . WalletState.getBlockHeight) + (Checkpoints.sparseArithmetic epochStability) + (fromIntegral $ getQuantity $ nodeTip ^. #blockHeight) + (snd (WalletState.fromWallet cp) NE.:| []) + let putPrologue cp = Delta.onDBVar walletState $ Delta.update $ \_ -> - let (prologue, wcp) = WalletState.fromWallet cp - slot = WalletState.getSlot wcp - in [ WalletState.UpdateCheckpoints - [ Checkpoints.PutCheckpoint slot wcp ] - , WalletState.ReplacePrologue prologue - ] + let (prologue, _) = WalletState.fromWallet cp + in [ WalletState.ReplacePrologue prologue ] atomically $ do - putCheckpoint cpB + putPrologue cpB putTxHistory txs Delta.onDBVar walletState $ WalletState.updateCheckpoints - $ Delta.update deltaPruneCheckpoints + $ Delta.update + $ deltaPruneCheckpoints cpB (currentTip cpB) it "Should spend collateral inputs and create spendable collateral \ \outputs if validation fails" $