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 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..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,6 +129,9 @@ newDBLayer timeInterpreter = do , rollbackTo = void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter + , 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 diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 00bdd4c2b96..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 @@ -381,6 +383,17 @@ newDBLayer trace fp timeInterpreter = do deleteWhere [ PoolRetirementSlot >. point ] -- 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 ] + deleteWhere [ PoolRetirementPoolId ==. pool ] + deleteWhere [ StakeDistributionPoolId ==. pool ] + , readPoolProductionCursor = \k -> do reverse . map (snd . fromPoolProduction . entityVal) <$> selectList [] diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 0141e1249bc..15740763a61 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 + ] + [PoolId $ BS.pack result | result /= s] + where + z = toEnum 0 -- NOTE Excepted to have a reasonnably small entropy instance Arbitrary PoolOwner where @@ -145,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) @@ -178,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. 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] 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