Record delisted pools in a dedicated table.

Record delisted pools in a dedicated table instead of using a field in
the `pool_registrations` table.

In the updated schema, a pool is delisted if (and only if) there is a
single row containing that pool's id in the `delisted_pools` table.

This solution has several advantages:

  1.  We only need a single database row to record that a pool is delisted.

  2.  We no longer need to carefully to ensure that all registration records
      for a particular pool have the same delisted status. A pool is either
      delisted or not delisted: the schema rules out all intermediate states.

  3.  Pools automatically remain delisted when rollbacks occur or when new
      certificates are published, with no extra effort.

  4.  The `putPoolRegistration` function no longer needs to read the
      most-recently-written registration entry before adding a new entry.

  5.  Each row in the `pool_registrations` table is now just an immutable
      record of a registration certificate.

  6.  The `PoolFlag` type is no longer necessary.

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

@@ -219,6 +219,9 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -- ^ Mark pools as delisted, e.g. due to non-compliance.
         -- This is stored as an attribute in the pool_registration table.
 
+    , readDelistedPools
+        :: stm [PoolId]
+
     , removePools
         :: [PoolId]
         -> stm ()

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

@@ -41,6 +41,7 @@ import Cardano.Pool.DB.Model
     , mPutSettings
     , mPutStakeDistribution
     , mReadCursor
+    , mReadDelistedPools
     , mReadLastMetadataGC
     , mReadPoolLifeCycleStatus
     , mReadPoolMetadata
@@ -152,6 +153,9 @@ newDBLayer timeInterpreter = do
         delistPools =
             void . alterPoolDB (const Nothing) db . mDelistPools
 
+        readDelistedPools =
+            readPoolDB db mReadDelistedPools
+
         removePools =
             void . alterPoolDB (const Nothing) db . mRemovePools
 

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

@@ -62,6 +62,7 @@ module Cardano.Pool.DB.Model
     , 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
 
@@ -430,16 +432,10 @@ mRollbackTo ti point = do
         | 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
+mDelistPools = modify #delisted . Set.union . 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,11 @@ 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
+        delistPools =
+            insertMany_ . fmap DelistedPool
+
+        readDelistedPools =
+            fmap (delistedPoolPoolId . entityVal) <$> selectList [] []
 
         removePools = mapM_ $ \pool -> do
             liftIO $ traceWith trace $ MsgRemovingPool pool
@@ -606,8 +595,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 +618,6 @@ newDBLayer trace fp timeInterpreter = do
                         , poolCost
                         , poolPledge
                         , poolMetadata
-                        , poolFlag
                         }
                 let cpt = CertificatePublicationTime {slotNo, slotInternalIndex}
                 pure (cpt, cert)

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
 
+DelistedPool sql=delisted_pool
+    delistedPoolPoolId                W.PoolId                      sql=pool_id
+    Primary delistedPoolPoolId
+    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

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

@@ -43,7 +43,6 @@ import Cardano.Wallet.Primitive.Types
     , CertificatePublicationTime (..)
     , EpochNo (..)
     , PoolCertificate (..)
-    , PoolFlag (..)
     , PoolId
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate (..)
@@ -1487,9 +1486,8 @@ prop_delistPools DBLayer {..} entries =
 
         -- delist pools
         run $ atomically $ delistPools (fmap (view #poolId . snd) entries)
-        entriesDelisted <- run . atomically $ L.sort . catMaybes
-            <$> mapM (readPoolRegistration . view #poolId . snd) entries
-        let expected = fmap (\(c, p) -> (c, p { poolFlag = Delisted })) entriesIn
+        entriesDelisted <- L.sort <$> run (atomically readDelistedPools)
+        let expected = view #poolId . snd <$> entriesIn
         monitor $ counterexample $ unlines
             [ "Expected: "
             , show expected
@@ -1513,16 +1511,15 @@ prop_delistPoolsPersists DBLayer {..} cert =
         let poolid = view #poolId . snd $ cert
         -- delist pool
         run $ atomically $ delistPools [poolid]
-        delisted <- run . atomically . readPoolRegistration $ poolid
-        let expected = (\(c, p) ->
-                (c, p { poolFlag = Delisted })) cert
+        delisted <- run $ atomically readDelistedPools
+        let expected = [poolid]
         assertWith "expected == delisted"
-            $ Just expected == delisted
+            $ expected == delisted
 
         -- insert the cert again
         run $ atomically
             $ uncurry putPoolRegistration cert
-        delistedAgain <- run . atomically . readPoolRegistration $ poolid
+        delistedAgain <- run $ atomically readDelistedPools
 
         monitor $ counterexample $ unlines
             [ "Expected: "
@@ -1531,7 +1528,7 @@ prop_delistPoolsPersists DBLayer {..} cert =
             , show delistedAgain
             ]
         assertWith "expected == delisted"
-            $ Just expected == delistedAgain
+            $ expected == delistedAgain
 
 descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation
 descSlotsPerPool pools = do

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Binary.hs

@@ -104,7 +104,6 @@ import Cardano.Wallet.Primitive.Types
     , EpochLength (..)
     , EpochNo (..)
     , Hash (..)
-    , PoolFlag (..)
     , PoolId (PoolId)
     , PoolOwner (..)
     , SealedTx (..)
@@ -1092,7 +1091,7 @@ poolRegistrationsFromBlock (Block _hdr fragments) = do
     let dummyPledge = Quantity 0
     let metadata = Nothing
     pure $ W.PoolRegistrationCertificate
-        poolId owners margin cost dummyPledge metadata NoPoolFlag
+        poolId owners margin cost dummyPledge metadata
 
 -- | If all incentives parameters are present in the blocks, returns a function
 -- that computes reward based on a given epoch.

lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs

@@ -56,7 +56,6 @@ import Cardano.Wallet.Primitive.Types
     , FeePolicy (..)
     , GenesisParameters (..)
     , Hash (..)
-    , PoolFlag (..)
     , PoolId (..)
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
@@ -428,8 +427,8 @@ instance Arbitrary PoolOwner where
     arbitrary = PoolOwner . B8.singleton <$> elements ['a'..'e']
 
 instance Arbitrary PoolRegistrationCertificate where
-    shrink (PoolRegistrationCertificate p o m c pl md fl) =
-        (\(p', NonEmpty o') -> PoolRegistrationCertificate p' o' m c pl md fl)
+    shrink (PoolRegistrationCertificate p o m c pl md) =
+        (\(p', NonEmpty o') -> PoolRegistrationCertificate p' o' m c pl md)
         <$> shrink (p, NonEmpty o)
     arbitrary = PoolRegistrationCertificate
         <$> arbitrary
@@ -438,7 +437,6 @@ instance Arbitrary PoolRegistrationCertificate where
         <*> fmap Quantity arbitrary
         <*> pure (Quantity 0)
         <*> pure Nothing
-        <*> pure NoPoolFlag
 
 instance Arbitrary RegistrationsTest where
     shrink (RegistrationsTest xs) = RegistrationsTest <$> shrink xs

lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs

@@ -759,7 +759,6 @@ fromShelleyRegistrationCert = \case
             , W.poolCost = lovelaceFromCoin (SL._poolCost pp)
             , W.poolPledge = lovelaceFromCoin (SL._poolPledge pp)
             , W.poolMetadata = fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp)
-            , W.poolFlag = W.NoPoolFlag
             }
         )