From acbad401f6e763e6f51ad34eabcfc318a43037bf Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 06:29:46 +0000 Subject: [PATCH 01/12] Add skeleton `removePools` operation to the pool DB. --- lib/core/src/Cardano/Pool/DB.hs | 5 +++++ lib/core/src/Cardano/Pool/DB/MVar.hs | 2 ++ lib/core/src/Cardano/Pool/DB/Sqlite.hs | 2 ++ 3 files changed, 9 insertions(+) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index df69acd1e6a..0b1c0e403c1 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -198,6 +198,11 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -> stm () -- ^ Remove all entries of slot ids newer than the argument + , removePools + :: [PoolId] + -> stm () + -- ^ Remove all data relating to the specified pools. + , cleanDB :: stm () -- ^ Clean a database diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index 1697bd54fd5..b0b5540b366 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -128,6 +128,8 @@ newDBLayer timeInterpreter = do , rollbackTo = void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter + , removePools = \_pools -> pure () + , cleanDB = void $ alterPoolDB (const Nothing) db mCleanPoolProduction diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 00bdd4c2b96..fe6f557d1e5 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -381,6 +381,8 @@ newDBLayer trace fp timeInterpreter = do deleteWhere [ PoolRetirementSlot >. point ] -- TODO: remove dangling metadata no longer attached to a pool + , removePools = \_pools -> pure () + , readPoolProductionCursor = \k -> do reverse . map (snd . fromPoolProduction . entityVal) <$> selectList [] From 4f3652ea413fd08dbe0b65cdeba216bc50ad919e Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 07:25:14 +0000 Subject: [PATCH 02/12] Provide model implementation of `removePools` pool DB operation. --- lib/core/src/Cardano/Pool/DB/MVar.hs | 4 +++- lib/core/src/Cardano/Pool/DB/Model.hs | 21 ++++++++++++++++++++- 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index b0b5540b366..7a82b8f4777 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -40,6 +40,7 @@ import Cardano.Pool.DB.Model , mReadStakeDistribution , mReadSystemSeed , mReadTotalProduction + , mRemovePools , mRollbackTo , mUnfetchedPoolMetadataRefs ) @@ -128,7 +129,8 @@ newDBLayer timeInterpreter = do , rollbackTo = void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter - , removePools = \_pools -> pure () + , removePools = + void . alterPoolDB (const Nothing) db . mRemovePools , cleanDB = void $ alterPoolDB (const Nothing) db mCleanPoolProduction diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 205f2c0c04a..e70bf57ab0e 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -51,6 +51,7 @@ module Cardano.Pool.DB.Model , mReadSystemSeed , mRollbackTo , mReadCursor + , mRemovePools ) where import Prelude @@ -83,7 +84,7 @@ import Data.Function import Data.Functor.Identity ( Identity (..) ) import Data.Generics.Internal.VL.Lens - ( view ) + ( over, view ) import Data.Map.Strict ( Map ) import Data.Maybe @@ -414,3 +415,21 @@ mRollbackTo timeInterpreter point PoolDatabase { pools discardBy get point' v | point' <= get point = Just v | otherwise = Nothing + +mRemovePools :: [PoolId] -> PoolDatabase -> (Either PoolErr (), PoolDatabase) +mRemovePools poolsToRemove db = + (pure (), dbFiltered) + where + dbFiltered = db + & over #distributions + (Map.map $ L.filter $ \(p, _) -> retain p) + & over #pools + (Map.filterWithKey $ \p _ -> retain p) + & over #owners + (Map.filterWithKey $ \p _ -> retain p) + & over #registrations + (Map.filterWithKey $ \(_, p) _ -> retain p) + & over #retirements + (Map.filterWithKey $ \(_, p) _ -> retain p) + retain p = p `Set.notMember` poolsToRemoveSet + poolsToRemoveSet = Set.fromList poolsToRemove From 1cfa66ccffb5f8a6c1b36cd4b9fac8ee17ed6b67 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 08:19:50 +0000 Subject: [PATCH 03/12] Provide SQLite implementation of `removePools` pool DB operation. --- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index fe6f557d1e5..3e0db482ae7 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -381,7 +381,12 @@ newDBLayer trace fp timeInterpreter = do deleteWhere [ PoolRetirementSlot >. point ] -- TODO: remove dangling metadata no longer attached to a pool - , removePools = \_pools -> pure () + , removePools = mapM_ $ \pool -> do + deleteWhere [ PoolProductionPoolId ==. pool ] + deleteWhere [ PoolOwnerPoolId ==. pool ] + deleteWhere [ PoolRegistrationPoolId ==. pool ] + deleteWhere [ PoolRetirementPoolId ==. pool ] + deleteWhere [ StakeDistributionPoolId ==. pool ] , readPoolProductionCursor = \k -> do reverse . map (snd . fromPoolProduction . entityVal) <$> selectList From fdf60845230e1e4b18da7e15c55ffa14e0618f5b Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 08:39:34 +0000 Subject: [PATCH 04/12] Add new constructor `MsgRemovingDatabaseEntity` to type `DBLog`. --- lib/core/src/Cardano/DB/Sqlite.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index 6ebcd025ea6..e2074d63516 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/lib/core/src/Cardano/DB/Sqlite.hs @@ -372,6 +372,7 @@ data DBLog | MsgWaitingForDatabase Text (Maybe Int) | MsgRemovingInUse Text Int | MsgRemoving Text + | MsgRemovingDatabaseEntity Text | MsgRemovingDatabaseFile Text DeleteSqliteDatabaseLog | MsgManualMigrationNeeded DBField Text | MsgManualMigrationNotNeeded DBField @@ -448,6 +449,7 @@ instance HasSeverityAnnotation DBLog where MsgWaitingForDatabase _ _ -> Info MsgRemovingInUse _ _ -> Notice MsgRemoving _ -> Info + MsgRemovingDatabaseEntity _ -> Notice MsgRemovingDatabaseFile _ msg -> getSeverityAnnotation msg MsgManualMigrationNeeded{} -> Notice MsgManualMigrationNotNeeded{} -> Debug @@ -484,6 +486,8 @@ instance ToText DBLog where "Attempting to remove the database anyway." MsgRemoving wid -> "Removing wallet's database. Wallet id was " <> wid + MsgRemovingDatabaseEntity msg -> + "Removing the following entity from the database: " <> msg MsgRemovingDatabaseFile wid msg -> "Removing " <> wid <> ": " <> toText msg MsgManualMigrationNeeded field value -> mconcat From 4482ba1e70ffa33308da6e717d5059e8673c9d08 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 08:40:19 +0000 Subject: [PATCH 05/12] Add logging to SQLite `removePools` DB operation. --- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 3e0db482ae7..5f533a70494 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -87,6 +87,8 @@ import Data.String.QQ ( s ) import Data.Text ( Text ) +import Data.Text.Class + ( toText ) import Data.Time.Clock ( UTCTime, addUTCTime, getCurrentTime ) import Data.Word @@ -382,6 +384,10 @@ newDBLayer trace fp timeInterpreter = do -- TODO: remove dangling metadata no longer attached to a pool , removePools = mapM_ $ \pool -> do + liftIO + $ traceWith trace + $ MsgRemovingDatabaseEntity + $ T.unwords [ "pool", toText pool ] deleteWhere [ PoolProductionPoolId ==. pool ] deleteWhere [ PoolOwnerPoolId ==. pool ] deleteWhere [ PoolRegistrationPoolId ==. pool ] From 0512a5524546bb7be231c6f15961990d6322dfff Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 09:21:39 +0000 Subject: [PATCH 06/12] Add property `prop_removePools`. --- .../test/unit/Cardano/Pool/DB/Properties.hs | 91 +++++++++++++++++++ 1 file changed, 91 insertions(+) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 4f3522d4a4a..92d6d85026b 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -50,6 +50,7 @@ import Cardano.Wallet.Primitive.Types , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , SlotNo (..) + , getPoolCertificatePoolId , getPoolRetirementCertificate ) import Cardano.Wallet.Unsafe @@ -64,6 +65,8 @@ import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except ( runExceptT ) +import Data.Bifunctor + ( bimap ) import Data.Function ( on, (&) ) import Data.Functor @@ -82,6 +85,8 @@ import Data.Ord ( Down (..) ) import Data.Quantity ( Quantity (..) ) +import Data.Text.Class + ( toText ) import Data.Word ( Word64 ) import Fmt @@ -188,6 +193,8 @@ properties = do (property . prop_rollbackRegistration) it "rollback of PoolRetirement" (property . prop_rollbackRetirement) + it "removePools" + (property . prop_removePools) it "readStake . putStake a1 . putStake s0 == pure a1" (property . prop_putStakePutStake) it "readSystemSeed is idempotent" @@ -844,6 +851,90 @@ prop_rollbackRetirement DBLayer{..} certificates = , ii <- [0 .. 3] ] +-- When we remove pools, check that: +-- +-- 1. We only remove data relating to the specified pools. +-- 2. We do not remove data relating to other pools. +-- +prop_removePools + :: DBLayer IO + -> [PoolCertificate] + -> Property +prop_removePools + DBLayer {..} certificates = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + prop = do + -- Firstly, publish an arbitrary set of pool certificates: + run $ atomically $ do + mapM_ (uncurry putCertificate) certificatePublications + -- Next, read the latest certificates for all pools: + poolIdsWithRegCertsAtStart <- run poolIdsWithRegCerts + poolIdsWithRetCertsAtStart <- run poolIdsWithRetCerts + -- Next, remove a subset of the pools: + run $ atomically $ removePools $ Set.toList poolsToRemove + -- Finally, see which certificates remain: + poolIdsWithRegCertsAtEnd <- run poolIdsWithRegCerts + poolIdsWithRetCertsAtEnd <- run poolIdsWithRetCerts + monitor $ counterexample $ T.unpack $ T.unlines + [ "All pools: " + , T.unlines (toText <$> Set.toList pools) + , "Pools to remove:" + , T.unlines (toText <$> Set.toList poolsToRemove) + , "Pools to retain:" + , T.unlines (toText <$> Set.toList poolsToRetain) + ] + assertWith "subset rule for registrations" $ + poolIdsWithRegCertsAtEnd `Set.isSubsetOf` poolsToRetain + assertWith "subset rule for retirements" $ + poolIdsWithRetCertsAtEnd `Set.isSubsetOf` poolsToRetain + assertWith "disjoint rule for registrations" $ + poolIdsWithRegCertsAtEnd `Set.disjoint` poolsToRemove + assertWith "disjoint rule for retirements" $ + poolIdsWithRetCertsAtEnd `Set.disjoint` poolsToRemove + assertWith "difference rule for registrations" $ + poolIdsWithRegCertsAtStart `Set.difference` poolsToRemove + == poolIdsWithRegCertsAtEnd + assertWith "difference rule for retirements" $ + poolIdsWithRetCertsAtStart `Set.difference` poolsToRemove + == poolIdsWithRetCertsAtEnd + + -- The complete set of all pools. + pools = Set.fromList $ getPoolCertificatePoolId <$> certificates + + -- Divide the set of pools into two sets of approximately the same size. + (poolsToRetain, poolsToRemove) = pools + & Set.toList + & L.splitAt (length pools `div` 2) + & bimap Set.fromList Set.fromList + + certificatePublications + :: [(CertificatePublicationTime, PoolCertificate)] + certificatePublications = publicationTimes `zip` certificates + + publicationTimes :: [CertificatePublicationTime] + publicationTimes = + [ CertificatePublicationTime (SlotNo sn) ii + | sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + + putCertificate cpt = \case + Registration cert -> + putPoolRegistration cpt cert + Retirement cert -> + putPoolRetirement cpt cert + + poolIdsWithRegCerts = + fmap (Set.fromList . fmap (view #poolId . snd) . catMaybes) + <$> atomically $ mapM readPoolRegistration $ Set.toList pools + + poolIdsWithRetCerts = + fmap (Set.fromList . fmap (view #poolId . snd) . catMaybes) + <$> atomically $ mapM readPoolRetirement $ Set.toList pools + prop_listRegisteredPools :: DBLayer IO -> [PoolRegistrationCertificate] From f415efaca91e01900c6000bf6b5bf4ea08e87a44 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 12:10:52 +0000 Subject: [PATCH 07/12] Improve shrinking for `PoolId`. --- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 21 ++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 0141e1249bc..4b28a5730f2 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -133,9 +133,24 @@ arbitraryChainLength = 10 -- NOTE Expected to have a high entropy instance Arbitrary PoolId where - arbitrary = do - bytes <- vector 32 - return $ PoolId $ B8.pack bytes + arbitrary = PoolId . BS.pack <$> vector 32 + shrink (PoolId p) = do + let s = BS.unpack p + result <- + [ -- Zero out everything: + replicate 32 z + -- Zero out different halves: + , replicate 16 z <> drop 16 s + , take 16 s <> replicate 16 z + -- Zero out different quarters: + , replicate 8 z <> drop 8 s + , take 8 s <> replicate 8 z <> drop 16 s + , take 16 s <> replicate 8 z <> drop 24 s + , take 24 s <> replicate 8 z + ] + if result == s then [] else [PoolId $ BS.pack result] + where + z = toEnum 0 -- NOTE Excepted to have a reasonnably small entropy instance Arbitrary PoolOwner where From 08dcfc9d7dd238ba39feccca7e6fab312558fbce Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 13:01:50 +0000 Subject: [PATCH 08/12] Improve shrinking for `PoolRegistrationCertificate`. --- lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 4b28a5730f2..f0ba073ade9 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -160,8 +160,9 @@ instance Arbitrary PoolOwner where instance Arbitrary PoolRegistrationCertificate where shrink (PoolRegistrationCertificate p xs m c pl md) = - (\xs' -> PoolRegistrationCertificate p xs' m c pl md) - <$> shrinkList (const []) xs + (\p' xs' -> PoolRegistrationCertificate p' xs' m c pl md) + <$> shrink p + <*> shrinkList (const []) xs arbitrary = PoolRegistrationCertificate <$> arbitrary <*> scale (`mod` 8) (listOf arbitrary) From 79e1724ef791862ad76ab12bef576e127a50afa7 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 13:02:06 +0000 Subject: [PATCH 09/12] Improve shrinking for `PoolCertificate`. --- lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index f0ba073ade9..1256f8f6866 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -194,7 +194,7 @@ instance Arbitrary PoolCertificate where , Retirement <$> arbitrary ] - shrink = const [] + shrink = genericShrink -- | Represents a valid sequence of registration and retirement certificates -- for a single pool. From 9e56f5cc6aef20da1b97630233f491e496d4251b Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Thu, 13 Aug 2020 13:18:32 +0000 Subject: [PATCH 10/12] Add a roundtrip textual encoding test for `PoolId`. --- lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs index 5a373d36fdf..e5f87117023 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/TypesSpec.hs @@ -65,6 +65,7 @@ import Cardano.Wallet.Primitive.Types , FeePolicy (..) , Hash (..) , HistogramBar (..) + , PoolId (..) , PoolOwner (..) , Range (..) , RangeBound (..) @@ -218,6 +219,7 @@ spec = do textRoundtrip $ Proxy @(Hash "Block") textRoundtrip $ Proxy @(Hash "BlockHeader") textRoundtrip $ Proxy @SyncTolerance + textRoundtrip $ Proxy @PoolId textRoundtrip $ Proxy @PoolOwner -- Extra hand-crafted tests @@ -1357,6 +1359,9 @@ instance Arbitrary Word31 where arbitrary = arbitrarySizedBoundedIntegral shrink = shrinkIntegral +instance Arbitrary PoolId where + arbitrary = PoolId . BS.pack <$> vector 32 + instance Arbitrary PoolOwner where arbitrary = PoolOwner . BS.pack <$> vector 32 From b7d6e010f99920ac4f176227a02629f6d1115a28 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 17 Aug 2020 04:16:45 +0000 Subject: [PATCH 11/12] Appease the hlint god. --- lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 1256f8f6866..04e81e06b2a 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -148,7 +148,7 @@ instance Arbitrary PoolId where , take 16 s <> replicate 8 z <> drop 24 s , take 24 s <> replicate 8 z ] - if result == s then [] else [PoolId $ BS.pack result] + [PoolId $ BS.pack result | not (result == s)] where z = toEnum 0 From 60390428c022a3d2e8e21a6736b0d56cbc88e268 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Mon, 17 Aug 2020 04:49:43 +0000 Subject: [PATCH 12/12] Appease the hlint god a second time. --- lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 04e81e06b2a..15740763a61 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -148,7 +148,7 @@ instance Arbitrary PoolId where , take 16 s <> replicate 8 z <> drop 24 s , take 24 s <> replicate 8 z ] - [PoolId $ BS.pack result | not (result == s)] + [PoolId $ BS.pack result | result /= s] where z = toEnum 0