Skip to content

Commit 84682f5

Browse files
jonathanknowlesjonathanknowles
committed
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.
1 parent 2df5061 commit 84682f5

File tree

13 files changed

+62
-98
lines changed

13 files changed

+62
-98
lines changed

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -219,6 +219,9 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
219219
-- ^ Mark pools as delisted, e.g. due to non-compliance.
220220
-- This is stored as an attribute in the pool_registration table.
221221

222+
, readDelistedPools
223+
:: stm [PoolId]
224+
222225
, removePools
223226
:: [PoolId]
224227
-> stm ()

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

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ import Cardano.Pool.DB.Model
4141
, mPutSettings
4242
, mPutStakeDistribution
4343
, mReadCursor
44+
, mReadDelistedPools
4445
, mReadLastMetadataGC
4546
, mReadPoolLifeCycleStatus
4647
, mReadPoolMetadata
@@ -152,6 +153,9 @@ newDBLayer timeInterpreter = do
152153
delistPools =
153154
void . alterPoolDB (const Nothing) db . mDelistPools
154155

156+
readDelistedPools =
157+
readPoolDB db mReadDelistedPools
158+
155159
removePools =
156160
void . alterPoolDB (const Nothing) db . mRemovePools
157161

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

Lines changed: 15 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -62,6 +62,7 @@ module Cardano.Pool.DB.Model
6262
, mReadCursor
6363
, mRemovePools
6464
, mDelistPools
65+
, mReadDelistedPools
6566
, mRemoveRetiredPools
6667
, mReadSettings
6768
, mPutSettings
@@ -80,7 +81,6 @@ import Cardano.Wallet.Primitive.Types
8081
, CertificatePublicationTime
8182
, EpochNo (..)
8283
, InternalState (..)
83-
, PoolFlag (..)
8484
, PoolId
8585
, PoolLifeCycleStatus (..)
8686
, PoolOwner (..)
@@ -116,6 +116,8 @@ import Data.Ord
116116
( Down (..) )
117117
import Data.Quantity
118118
( Quantity (..) )
119+
import Data.Set
120+
( Set )
119121
import Data.Time.Clock.POSIX
120122
( POSIXTime )
121123
import Data.Word
@@ -152,6 +154,8 @@ data PoolDatabase = PoolDatabase
152154
!(Map (CertificatePublicationTime, PoolId) PoolRetirementCertificate)
153155
-- ^ On-chain retirements associated with pools
154156

157+
, delisted :: !(Set PoolId)
158+
155159
, metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
156160
-- ^ Off-chain metadata cached in database
157161

@@ -184,9 +188,9 @@ instance Eq SystemSeed where
184188

185189
-- | Produces an empty model pool production database.
186190
emptyPoolDatabase :: PoolDatabase
187-
emptyPoolDatabase =
188-
PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
189-
mempty defaultSettings defaultInternalState
191+
emptyPoolDatabase = PoolDatabase
192+
mempty mempty mempty mempty mempty mempty mempty mempty NotSeededYet
193+
mempty defaultSettings defaultInternalState
190194

191195
{-------------------------------------------------------------------------------
192196
Model Operation Types
@@ -254,12 +258,10 @@ mPutPoolRegistration
254258
-> PoolRegistrationCertificate
255259
-> ModelOp ()
256260
mPutPoolRegistration cpt cert = do
257-
old <- fmap snd <$> mReadPoolRegistration (view #poolId cert)
258-
let flag = maybe NoPoolFlag poolFlag old
259261
modify #owners
260262
$ Map.insert poolId poolOwners
261263
modify #registrations
262-
$ Map.insert (cpt, poolId) (cert { poolFlag = flag })
264+
$ Map.insert (cpt, poolId) cert
263265
where
264266
PoolRegistrationCertificate {poolId, poolOwners} = cert
265267

@@ -430,16 +432,10 @@ mRollbackTo ti point = do
430432
| otherwise = Nothing
431433

432434
mDelistPools :: [PoolId] -> ModelOp ()
433-
mDelistPools poolsToDelist =
434-
modify #registrations
435-
$ Map.mapWithKey
436-
$ \(_, pid) a ->
437-
if updateThis pid
438-
then a {poolFlag = Delisted}
439-
else a
440-
where
441-
updateThis p = p `Set.member` poolsToDelistSet
442-
poolsToDelistSet = Set.fromList poolsToDelist
435+
mDelistPools = modify #delisted . Set.union . Set.fromList
436+
437+
mReadDelistedPools :: ModelOp [PoolId]
438+
mReadDelistedPools = Set.toList <$> get #delisted
443439

444440
mRemovePools :: [PoolId] -> ModelOp ()
445441
mRemovePools poolsToRemove = do
@@ -453,6 +449,8 @@ mRemovePools poolsToRemove = do
453449
$ Map.filterWithKey $ \(_, p) _ -> retain p
454450
modify #retirements
455451
$ Map.filterWithKey $ \(_, p) _ -> retain p
452+
modify #delisted
453+
$ Set.filter retain
456454
where
457455
retain p = p `Set.notMember` poolsToRemoveSet
458456
poolsToRemoveSet = Set.fromList poolsToRemove

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

Lines changed: 10 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,6 @@ import Cardano.Wallet.Primitive.Types
6262
( BlockHeader (..)
6363
, CertificatePublicationTime (..)
6464
, EpochNo (..)
65-
, PoolFlag (..)
6665
, PoolId (..)
6766
, PoolLifeCycleStatus (..)
6867
, PoolRegistrationCertificate (..)
@@ -120,12 +119,10 @@ import Database.Persist.Sql
120119
, insert_
121120
, rawSql
122121
, repsert
123-
, repsertMany
124122
, selectFirst
125123
, selectList
126124
, toPersistValue
127125
, update
128-
, (<-.)
129126
, (<.)
130127
, (=.)
131128
, (==.)
@@ -295,9 +292,6 @@ newDBLayer trace fp timeInterpreter = do
295292
]
296293
let poolRegistrationKey = PoolRegistrationKey
297294
poolId slotNo slotInternalIndex
298-
prevResult <- selectFirst
299-
[ PoolRegistrationPoolId ==. poolId ]
300-
[ ]
301295
let poolRegistrationRow = PoolRegistration
302296
(poolId)
303297
(slotNo)
@@ -310,7 +304,6 @@ newDBLayer trace fp timeInterpreter = do
310304
(getQuantity $ poolPledge cert)
311305
(fst <$> poolMetadata cert)
312306
(snd <$> poolMetadata cert)
313-
(maybe NoPoolFlag (poolRegistrationFlag . entityVal) prevResult)
314307
_ <- repsert poolRegistrationKey poolRegistrationRow
315308
insertMany_ $
316309
zipWith
@@ -455,7 +448,6 @@ newDBLayer trace fp timeInterpreter = do
455448
, Single fieldMarginDenominator
456449
, Single fieldMetadataHash
457450
, Single fieldMetadataUrl
458-
, Single fieldFlag
459451
) = do
460452
regCert <- parseRegistrationCertificate
461453
parseRetirementCertificate <&> maybe
@@ -469,7 +461,6 @@ newDBLayer trace fp timeInterpreter = do
469461
<*> (Quantity <$> fromPersistValue fieldCost)
470462
<*> (Quantity <$> fromPersistValue fieldPledge)
471463
<*> parseMetadata
472-
<*> fromPersistValue fieldFlag
473464

474465
parseRetirementCertificate = do
475466
poolId <- fromPersistValue fieldPoolId
@@ -500,13 +491,11 @@ newDBLayer trace fp timeInterpreter = do
500491
deleteWhere [ BlockSlot >. point ]
501492
-- TODO: remove dangling metadata no longer attached to a pool
502493

503-
delistPools pools = do
504-
px <- selectList
505-
[ PoolRegistrationPoolId <-. pools ]
506-
[ ]
507-
repsertMany $ fmap
508-
(\(Entity k val) -> (k, val {poolRegistrationFlag = Delisted}))
509-
px
494+
delistPools =
495+
insertMany_ . fmap DelistedPool
496+
497+
readDelistedPools =
498+
fmap (delistedPoolPoolId . entityVal) <$> selectList [] []
510499

511500
removePools = mapM_ $ \pool -> do
512501
liftIO $ traceWith trace $ MsgRemovingPool pool
@@ -515,6 +504,7 @@ newDBLayer trace fp timeInterpreter = do
515504
deleteWhere [ PoolRegistrationPoolId ==. pool ]
516505
deleteWhere [ PoolRetirementPoolId ==. pool ]
517506
deleteWhere [ StakeDistributionPoolId ==. pool ]
507+
deleteWhere [ DelistedPoolPoolId ==. pool ]
518508

519509
removeRetiredPools epoch =
520510
bracketTracer traceOuter action
@@ -580,6 +570,7 @@ newDBLayer trace fp timeInterpreter = do
580570
deleteWhere ([] :: [Filter PoolOwner])
581571
deleteWhere ([] :: [Filter PoolRegistration])
582572
deleteWhere ([] :: [Filter PoolRetirement])
573+
deleteWhere ([] :: [Filter DelistedPool])
583574
deleteWhere ([] :: [Filter StakeDistribution])
584575
deleteWhere ([] :: [Filter PoolMetadata])
585576
deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
@@ -606,8 +597,7 @@ newDBLayer trace fp timeInterpreter = do
606597
poolCost_
607598
poolPledge_
608599
poolMetadataUrl
609-
poolMetadataHash
610-
poolFlag = entityVal meta
600+
poolMetadataHash = entityVal meta
611601
let poolMargin = unsafeMkPercentage $
612602
toRational $ marginNum % marginDen
613603
let poolCost = Quantity poolCost_
@@ -630,7 +620,6 @@ newDBLayer trace fp timeInterpreter = do
630620
, poolCost
631621
, poolPledge
632622
, poolMetadata
633-
, poolFlag
634623
}
635624
let cpt = CertificatePublicationTime {slotNo, slotInternalIndex}
636625
pure (cpt, cert)
@@ -753,8 +742,7 @@ activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [i|
753742
margin_numerator,
754743
margin_denominator,
755744
metadata_hash,
756-
metadata_url,
757-
active_pool_registrations.flag as flag
745+
metadata_url
758746
FROM
759747
active_pool_registrations
760748
LEFT JOIN
@@ -809,8 +797,7 @@ activePoolRegistrations = DatabaseView "active_pool_registrations" [i|
809797
margin_numerator,
810798
margin_denominator,
811799
metadata_hash,
812-
metadata_url,
813-
flag
800+
metadata_url
814801
FROM (
815802
SELECT row_number() OVER w AS r, *
816803
FROM pool_registration

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

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -120,11 +120,15 @@ PoolRegistration sql=pool_registration
120120
poolRegistrationPledge Word64 sql=pledge
121121
poolRegistrationMetadataUrl W.StakePoolMetadataUrl Maybe sql=metadata_url
122122
poolRegistrationMetadataHash W.StakePoolMetadataHash Maybe sql=metadata_hash
123-
poolRegistrationFlag W.PoolFlag sql=flag
124123

125124
Primary poolRegistrationPoolId poolRegistrationSlot poolRegistrationSlotInternalIndex
126125
deriving Show Generic
127126

127+
DelistedPool sql=delisted_pool
128+
delistedPoolPoolId W.PoolId sql=pool_id
129+
Primary delistedPoolPoolId
130+
deriving Show Generic
131+
128132
-- Mapping of retirement certificates to pools
129133
PoolRetirement sql=pool_retirement
130134
poolRetirementPoolId W.PoolId sql=pool_id

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

Lines changed: 0 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,6 @@ import Cardano.Wallet.Primitive.Types
4343
, EpochNo (..)
4444
, FeePolicy
4545
, Hash (..)
46-
, PoolFlag (..)
4746
, PoolId
4847
, PoolMetadataSource
4948
, PoolOwner (..)
@@ -680,10 +679,3 @@ instance PersistField POSIXTime where
680679

681680
instance PersistFieldSql POSIXTime where
682681
sqlType _ = sqlType (Proxy @Text)
683-
684-
instance PersistField PoolFlag where
685-
toPersistValue = toPersistValue . toText
686-
fromPersistValue = fromPersistValueFromText
687-
688-
instance PersistFieldSql PoolFlag where
689-
sqlType _ = sqlType (Proxy @Text)

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

Lines changed: 0 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -192,8 +192,6 @@ module Cardano.Wallet.Primitive.Types
192192
, InternalState (..)
193193
, defaultInternalState
194194

195-
-- * other
196-
, PoolFlag (..)
197195
) where
198196

199197
import Prelude
@@ -1792,7 +1790,6 @@ data PoolRegistrationCertificate = PoolRegistrationCertificate
17921790
, poolCost :: Quantity "lovelace" Word64
17931791
, poolPledge :: Quantity "lovelace" Word64
17941792
, poolMetadata :: Maybe (StakePoolMetadataUrl, StakePoolMetadataHash)
1795-
, poolFlag :: PoolFlag
17961793
} deriving (Generic, Show, Eq, Ord)
17971794

17981795
instance NFData PoolRegistrationCertificate
@@ -2042,14 +2039,3 @@ instance FromJSON PoolMetadataSource where
20422039

20432040
instance ToJSON PoolMetadataSource where
20442041
toJSON = toJSON . toText
2045-
2046-
data PoolFlag = NoPoolFlag | Delisted
2047-
deriving (Generic, Bounded, Enum, Show, Eq, Ord)
2048-
2049-
instance NFData PoolFlag
2050-
2051-
instance ToText PoolFlag where
2052-
toText = toTextFromBoundedEnum KebabLowerCase
2053-
2054-
instance FromText PoolFlag where
2055-
fromText = fromTextToBoundedEnum KebabLowerCase

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

Lines changed: 0 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import Cardano.Wallet.Primitive.Types
2828
, EpochNo (..)
2929
, Hash (..)
3030
, PoolCertificate (..)
31-
, PoolFlag (..)
3231
, PoolId (..)
3332
, PoolMetadataSource (..)
3433
, PoolMetadataSource (..)
@@ -165,10 +164,6 @@ instance Arbitrary PoolOwner where
165164
byte <- elements ['0'..'8']
166165
return $ PoolOwner $ B8.pack (replicate 32 byte)
167166

168-
instance Arbitrary PoolFlag where
169-
arbitrary = arbitraryBoundedEnum
170-
shrink = const []
171-
172167
instance Arbitrary PoolRegistrationCertificate where
173168
shrink regCert = do
174169
shrunkPoolId <- shrink $ view #poolId regCert
@@ -188,7 +183,6 @@ instance Arbitrary PoolRegistrationCertificate where
188183
<*> fmap Quantity arbitrary
189184
<*> fmap Quantity arbitrary
190185
<*> oneof [pure Nothing, Just <$> genMetadata]
191-
<*> pure NoPoolFlag
192186
where
193187
genMetadata = (,)
194188
<$> fmap StakePoolMetadataUrl genURL

0 commit comments

Comments
 (0)