Try #2038:

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

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

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
 

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

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
                 []

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.

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]

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