Record delisted pools in a dedicated table.

lib/core/src/Cardano/Pool/DB.hs

@@ -213,11 +213,15 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm ()
         -- ^ Remove all entries of slot ids newer than the argument
 
-    , delistPools
+    , putDelistedPools
         :: [PoolId]
         -> stm ()
-        -- ^ Mark pools as delisted, e.g. due to non-compliance.
-        -- This is stored as an attribute in the pool_registration table.
+        -- ^ Overwrite the set of delisted pools with a completely new set.
+        -- Pools may be delisted for reasons such as non-compliance.
+
+    , readDelistedPools
+        :: stm [PoolId]
+        -- ^ Fetch the set of delisted pools.
 
     , removePools
         :: [PoolId]

lib/core/src/Cardano/Pool/DB/MVar.hs

@@ -26,11 +26,11 @@ import Cardano.Pool.DB.Model
     , emptyPoolDatabase
     , mCleanDatabase
     , mCleanPoolMetadata
-    , mDelistPools
     , mListHeaders
     , mListPoolLifeCycleData
     , mListRegisteredPools
     , mListRetiredPools
+    , mPutDelistedPools
     , mPutFetchAttempt
     , mPutHeader
     , mPutLastMetadataGC
@@ -41,6 +41,7 @@ import Cardano.Pool.DB.Model
     , mPutSettings
     , mPutStakeDistribution
     , mReadCursor
+    , mReadDelistedPools
     , mReadLastMetadataGC
     , mReadPoolLifeCycleStatus
     , mReadPoolMetadata
@@ -149,8 +150,11 @@ newDBLayer timeInterpreter = do
         rollbackTo =
             void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter
 
-        delistPools =
-            void . alterPoolDB (const Nothing) db . mDelistPools
+        putDelistedPools =
+            void . alterPoolDB (const Nothing) db . mPutDelistedPools
+
+        readDelistedPools =
+            readPoolDB db mReadDelistedPools
 
         removePools =
             void . alterPoolDB (const Nothing) db . mRemovePools

lib/core/src/Cardano/Pool/DB/Model.hs

@@ -51,6 +51,7 @@ module Cardano.Pool.DB.Model
     , mPutPoolRetirement
     , mReadPoolRetirement
     , mUnfetchedPoolMetadataRefs
+    , mPutDelistedPools
     , mPutFetchAttempt
     , mPutPoolMetadata
     , mListPoolLifeCycleData
@@ -61,7 +62,7 @@ module Cardano.Pool.DB.Model
     , mRollbackTo
     , mReadCursor
     , mRemovePools
-    , mDelistPools
+    , mReadDelistedPools
     , mRemoveRetiredPools
     , mReadSettings
     , mPutSettings
@@ -80,7 +81,6 @@ import Cardano.Wallet.Primitive.Types
     , CertificatePublicationTime
     , EpochNo (..)
     , InternalState (..)
-    , PoolFlag (..)
     , PoolId
     , PoolLifeCycleStatus (..)
     , PoolOwner (..)
@@ -116,6 +116,8 @@ import Data.Ord
     ( Down (..) )
 import Data.Quantity
     ( Quantity (..) )
+import Data.Set
+    ( Set )
 import Data.Time.Clock.POSIX
     ( POSIXTime )
 import Data.Word
@@ -152,6 +154,8 @@ data PoolDatabase = PoolDatabase
         !(Map (CertificatePublicationTime, PoolId) PoolRetirementCertificate)
     -- ^ On-chain retirements associated with pools
 
+    , delisted :: !(Set PoolId)
+
     , metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
     -- ^ Off-chain metadata cached in database
 
@@ -184,9 +188,9 @@ instance Eq SystemSeed where
 
 -- | Produces an empty model pool production database.
 emptyPoolDatabase :: PoolDatabase
-emptyPoolDatabase =
-    PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
-        mempty defaultSettings defaultInternalState
+emptyPoolDatabase = PoolDatabase
+    mempty mempty mempty mempty mempty mempty mempty mempty NotSeededYet
+    mempty defaultSettings defaultInternalState
 
 {-------------------------------------------------------------------------------
                                   Model Operation Types
@@ -254,12 +258,10 @@ mPutPoolRegistration
     -> PoolRegistrationCertificate
     -> ModelOp ()
 mPutPoolRegistration cpt cert = do
-    old <- fmap snd <$> mReadPoolRegistration (view #poolId cert)
-    let flag = maybe NoPoolFlag poolFlag old
     modify #owners
         $ Map.insert poolId poolOwners
     modify #registrations
-        $ Map.insert (cpt, poolId) (cert { poolFlag = flag })
+        $ Map.insert (cpt, poolId) cert
   where
     PoolRegistrationCertificate {poolId, poolOwners} = cert
 
@@ -429,17 +431,11 @@ mRollbackTo ti point = do
         | point' <= getPoint point = Just v
         | otherwise = Nothing
 
-mDelistPools :: [PoolId] -> ModelOp ()
-mDelistPools poolsToDelist =
-    modify #registrations
-        $ Map.mapWithKey
-        $ \(_, pid) a ->
-            if updateThis pid
-            then a {poolFlag = Delisted}
-            else a
-  where
-    updateThis p = p `Set.member` poolsToDelistSet
-    poolsToDelistSet = Set.fromList poolsToDelist
+mPutDelistedPools :: [PoolId] -> ModelOp ()
+mPutDelistedPools = modify #delisted . const . Set.fromList
+
+mReadDelistedPools :: ModelOp [PoolId]
+mReadDelistedPools = Set.toList <$> get #delisted
 
 mRemovePools :: [PoolId] -> ModelOp ()
 mRemovePools poolsToRemove = do

lib/core/src/Cardano/Pool/DB/Sqlite.hs

@@ -62,7 +62,6 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , CertificatePublicationTime (..)
     , EpochNo (..)
-    , PoolFlag (..)
     , PoolId (..)
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate (..)
@@ -120,12 +119,10 @@ import Database.Persist.Sql
     , insert_
     , rawSql
     , repsert
-    , repsertMany
     , selectFirst
     , selectList
     , toPersistValue
     , update
-    , (<-.)
     , (<.)
     , (=.)
     , (==.)
@@ -295,9 +292,6 @@ newDBLayer trace fp timeInterpreter = do
                 ]
             let poolRegistrationKey = PoolRegistrationKey
                     poolId slotNo slotInternalIndex
-            prevResult <- selectFirst
-                [ PoolRegistrationPoolId ==. poolId ]
-                [ ]
             let poolRegistrationRow = PoolRegistration
                     (poolId)
                     (slotNo)
@@ -310,7 +304,6 @@ newDBLayer trace fp timeInterpreter = do
                     (getQuantity $ poolPledge cert)
                     (fst <$> poolMetadata cert)
                     (snd <$> poolMetadata cert)
-                    (maybe NoPoolFlag (poolRegistrationFlag . entityVal) prevResult)
             _ <- repsert poolRegistrationKey poolRegistrationRow
             insertMany_ $
                 zipWith
@@ -455,7 +448,6 @@ newDBLayer trace fp timeInterpreter = do
                 , Single fieldMarginDenominator
                 , Single fieldMetadataHash
                 , Single fieldMetadataUrl
-                , Single fieldFlag
                 ) = do
                 regCert <- parseRegistrationCertificate
                 parseRetirementCertificate <&> maybe
@@ -469,7 +461,6 @@ newDBLayer trace fp timeInterpreter = do
                     <*> (Quantity <$> fromPersistValue fieldCost)
                     <*> (Quantity <$> fromPersistValue fieldPledge)
                     <*> parseMetadata
-                    <*> fromPersistValue fieldFlag
 
                 parseRetirementCertificate = do
                     poolId <- fromPersistValue fieldPoolId
@@ -500,13 +491,12 @@ newDBLayer trace fp timeInterpreter = do
             deleteWhere [ BlockSlot >. point ]
             -- TODO: remove dangling metadata no longer attached to a pool
 
-        delistPools pools = do
-            px <- selectList
-                [ PoolRegistrationPoolId <-. pools ]
-                [  ]
-            repsertMany $ fmap
-                (\(Entity k val) -> (k, val {poolRegistrationFlag = Delisted}))
-                px
+        putDelistedPools pools = do
+            deleteWhere ([] :: [Filter PoolDelistment])
+            insertMany_ $ fmap PoolDelistment pools
+
+        readDelistedPools =
+            fmap (delistedPoolId . entityVal) <$> selectList [] []
 
         removePools = mapM_ $ \pool -> do
             liftIO $ traceWith trace $ MsgRemovingPool pool
@@ -580,6 +570,7 @@ newDBLayer trace fp timeInterpreter = do
             deleteWhere ([] :: [Filter PoolOwner])
             deleteWhere ([] :: [Filter PoolRegistration])
             deleteWhere ([] :: [Filter PoolRetirement])
+            deleteWhere ([] :: [Filter PoolDelistment])
             deleteWhere ([] :: [Filter StakeDistribution])
             deleteWhere ([] :: [Filter PoolMetadata])
             deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
@@ -606,8 +597,7 @@ newDBLayer trace fp timeInterpreter = do
                         poolCost_
                         poolPledge_
                         poolMetadataUrl
-                        poolMetadataHash
-                        poolFlag = entityVal meta
+                        poolMetadataHash = entityVal meta
                 let poolMargin = unsafeMkPercentage $
                         toRational $ marginNum % marginDen
                 let poolCost = Quantity poolCost_
@@ -630,7 +620,6 @@ newDBLayer trace fp timeInterpreter = do
                         , poolCost
                         , poolPledge
                         , poolMetadata
-                        , poolFlag
                         }
                 let cpt = CertificatePublicationTime {slotNo, slotInternalIndex}
                 pure (cpt, cert)
@@ -753,8 +742,7 @@ activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [i|
         margin_numerator,
         margin_denominator,
         metadata_hash,
-        metadata_url,
-        active_pool_registrations.flag as flag
+        metadata_url
     FROM
         active_pool_registrations
     LEFT JOIN
@@ -809,8 +797,7 @@ activePoolRegistrations = DatabaseView "active_pool_registrations" [i|
         margin_numerator,
         margin_denominator,
         metadata_hash,
-        metadata_url,
-        flag
+        metadata_url
     FROM (
         SELECT row_number() OVER w AS r, *
         FROM pool_registration

lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs

@@ -120,11 +120,15 @@ PoolRegistration sql=pool_registration
     poolRegistrationPledge            Word64                        sql=pledge
     poolRegistrationMetadataUrl       W.StakePoolMetadataUrl  Maybe sql=metadata_url
     poolRegistrationMetadataHash      W.StakePoolMetadataHash Maybe sql=metadata_hash
-    poolRegistrationFlag              W.PoolFlag                    sql=flag
 
     Primary poolRegistrationPoolId poolRegistrationSlot poolRegistrationSlotInternalIndex
     deriving Show Generic
 
+PoolDelistment sql=pool_delistment
+    delistedPoolId                W.PoolId                      sql=pool_id
+    Primary delistedPoolId
+    deriving Show Generic
+
 -- Mapping of retirement certificates to pools
 PoolRetirement sql=pool_retirement
     poolRetirementPoolId              W.PoolId            sql=pool_id

lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs

@@ -43,7 +43,6 @@ import Cardano.Wallet.Primitive.Types
     , EpochNo (..)
     , FeePolicy
     , Hash (..)
-    , PoolFlag (..)
     , PoolId
     , PoolMetadataSource
     , PoolOwner (..)
@@ -680,10 +679,3 @@ instance PersistField POSIXTime where
 
 instance PersistFieldSql POSIXTime where
     sqlType _ = sqlType (Proxy @Text)
-
-instance PersistField PoolFlag where
-    toPersistValue = toPersistValue . toText
-    fromPersistValue = fromPersistValueFromText
-
-instance PersistFieldSql PoolFlag where
-    sqlType _ = sqlType (Proxy @Text)

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -192,8 +192,6 @@ module Cardano.Wallet.Primitive.Types
     , InternalState (..)
     , defaultInternalState
 
-    -- * other
-    , PoolFlag (..)
     ) where
 
 import Prelude
@@ -1792,7 +1790,6 @@ data PoolRegistrationCertificate = PoolRegistrationCertificate
     , poolCost :: Quantity "lovelace" Word64
     , poolPledge :: Quantity "lovelace" Word64
     , poolMetadata :: Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
-    , poolFlag :: PoolFlag
     } deriving (Generic, Show, Eq, Ord)
 
 instance NFData PoolRegistrationCertificate
@@ -2042,14 +2039,3 @@ instance FromJSON PoolMetadataSource where
 
 instance ToJSON PoolMetadataSource where
     toJSON = toJSON . toText
-
-data PoolFlag = NoPoolFlag | Delisted
-    deriving (Generic, Bounded, Enum, Show, Eq, Ord)
-
-instance NFData PoolFlag
-
-instance ToText PoolFlag where
-    toText = toTextFromBoundedEnum KebabLowerCase
-
-instance FromText PoolFlag where
-    fromText = fromTextToBoundedEnum KebabLowerCase

lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs

@@ -28,7 +28,6 @@ import Cardano.Wallet.Primitive.Types
     , EpochNo (..)
     , Hash (..)
     , PoolCertificate (..)
-    , PoolFlag (..)
     , PoolId (..)
     , PoolMetadataSource (..)
     , PoolMetadataSource (..)
@@ -165,10 +164,6 @@ instance Arbitrary PoolOwner where
         byte <- elements ['0'..'8']
         return $ PoolOwner $ B8.pack (replicate 32 byte)
 
-instance Arbitrary PoolFlag where
-    arbitrary = arbitraryBoundedEnum
-    shrink = const []
-
 instance Arbitrary PoolRegistrationCertificate where
     shrink regCert = do
         shrunkPoolId <- shrink $ view #poolId regCert
@@ -188,7 +183,6 @@ instance Arbitrary PoolRegistrationCertificate where
         <*> fmap Quantity arbitrary
         <*> fmap Quantity arbitrary
         <*> oneof [pure Nothing, Just <$> genMetadata]
-        <*> pure NoPoolFlag
       where
         genMetadata = (,)
             <$> fmap StakePoolMetadataUrl genURL