Add pool DB operation removePools

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

@@ -27,10 +27,15 @@ module Cardano.Pool.DB.Sqlite
     , withDBLayer
     , defaultFilePath
     , DatabaseView (..)
+    , PoolDbLog (..)
     ) where
 
 import Prelude
 
+import Cardano.BM.Data.Severity
+    ( Severity (..) )
+import Cardano.BM.Data.Tracer
+    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.DB.Sqlite
     ( DBField (..)
     , DBLog (..)
@@ -70,7 +75,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
     ( ExceptT (..) )
 import Control.Tracer
-    ( Tracer, traceWith )
+    ( Tracer, contramap, traceWith )
 import Data.Either
     ( rights )
 import Data.Generics.Internal.VL.Lens
@@ -87,6 +92,8 @@ import Data.String.QQ
     ( s )
 import Data.Text
     ( Text )
+import Data.Text.Class
+    ( ToText (..), toText )
 import Data.Time.Clock
     ( UTCTime, addUTCTime, getCurrentTime )
 import Data.Word
@@ -140,7 +147,7 @@ defaultFilePath = (</> "stake-pools.sqlite")
 -- If the given file path does not exist, it will be created by the sqlite
 -- library.
 withDBLayer
-    :: Tracer IO DBLog
+    :: Tracer IO PoolDbLog
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
@@ -149,7 +156,7 @@ withDBLayer
        -- ^ Action to run.
     -> IO a
 withDBLayer trace fp timeInterpreter action = do
-    traceWith trace (MsgWillOpenDB fp)
+    traceWith trace (MsgGeneric $ MsgWillOpenDB fp)
     bracket before after (action . snd)
   where
     before = newDBLayer trace fp timeInterpreter
@@ -166,7 +173,7 @@ withDBLayer trace fp timeInterpreter action = do
 -- should be closed with 'destroyDBLayer'. If you use 'withDBLayer' then both of
 -- these things will be handled for you.
 newDBLayer
-    :: Tracer IO DBLog
+    :: Tracer IO PoolDbLog
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
@@ -176,7 +183,7 @@ newDBLayer trace fp timeInterpreter = do
     let io = startSqliteBackend
             (migrateManually trace)
             migrateAll
-            trace
+            (contramap MsgGeneric trace)
             fp
     ctx@SqliteContext{runQuery} <- handlingPersistError trace fp io
     return (ctx, DBLayer
@@ -381,6 +388,14 @@ 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 $ MsgRemovingPool 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
                 []
@@ -469,7 +484,7 @@ newDBLayer trace fp timeInterpreter = do
                 pure (cpt, cert)
 
 migrateManually
-    :: Tracer IO DBLog
+    :: Tracer IO PoolDbLog
     -> ManualMigration
 migrateManually _tr =
     ManualMigration $ \conn ->
@@ -545,7 +560,7 @@ activePoolRetirements = DatabaseView "active_pool_retirements" [s|
 -- with ugly work-around we can, at least for now, reset it semi-manually when
 -- needed to keep things tidy here.
 handlingPersistError
-    :: Tracer IO DBLog
+    :: Tracer IO PoolDbLog
        -- ^ Logging object
     -> Maybe FilePath
        -- ^ Database file location, or Nothing for in-memory database
@@ -555,7 +570,7 @@ handlingPersistError
 handlingPersistError trace fp action = action >>= \case
     Right ctx -> pure ctx
     Left _ -> do
-        traceWith trace MsgDatabaseReset
+        traceWith trace $ MsgGeneric MsgDatabaseReset
         maybe (pure ()) removeFile fp
         action >>= either throwIO pure
 
@@ -656,3 +671,28 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
         , description = poolMetadataDescription meta
         , homepage = poolMetadataHomepage meta
         }
+
+{-------------------------------------------------------------------------------
+                                   Logging
+-------------------------------------------------------------------------------}
+
+data PoolDbLog
+    = MsgGeneric DBLog
+    | MsgRemovingPool PoolId
+    deriving (Eq, Show)
+
+instance HasPrivacyAnnotation PoolDbLog
+
+instance HasSeverityAnnotation PoolDbLog where
+    getSeverityAnnotation = \case
+        MsgGeneric e -> getSeverityAnnotation e
+        MsgRemovingPool {} -> Notice
+
+instance ToText PoolDbLog where
+    toText = \case
+        MsgGeneric e -> toText e
+        MsgRemovingPool p -> mconcat
+            [ "Removing the following pool from the database: "
+            , toText p
+            , "."
+            ]

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.