Add {put,read}PoolRetirement DB operations.

cardano-foundation · Jul 3, 2020 · ae2f140 · ae2f140
1 parent e122bdd
commit ae2f140
Show file tree

Hide file tree

Showing 4 changed files with 76 additions and 1 deletion.
diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs
@@ -24,6 +24,7 @@ import Cardano.Wallet.Primitive.Types
     , EpochNo (..)
     , PoolId
     , PoolRegistrationCertificate
+    , PoolRetirementCertificate
     , SlotId (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
@@ -112,6 +113,17 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm (Maybe PoolRegistrationCertificate)
         -- ^ Find a registration certificate associated to a given pool
 
+    , putPoolRetirement
+        :: SlotId
+        -> PoolRetirementCertificate
+        -> stm ()
+        -- ^ Add a retirement certificate for a particular pool.
+
+    , readPoolRetirement
+        :: PoolId
+        -> stm (Maybe PoolRetirementCertificate)
+        -- ^ Find a retirement certificate for a particular pool.
+
     , unfetchedPoolMetadataRefs
         :: Int
         -> stm [(StakePoolMetadataUrl, StakePoolMetadataHash)]

diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs
@@ -29,11 +29,13 @@ import Cardano.Pool.DB.Model
     , mPutPoolMetadata
     , mPutPoolProduction
     , mPutPoolRegistration
+    , mPutPoolRetirement
     , mPutStakeDistribution
     , mReadCursor
     , mReadPoolMetadata
     , mReadPoolProduction
     , mReadPoolRegistration
+    , mReadPoolRetirement
     , mReadStakeDistribution
     , mReadSystemSeed
     , mReadTotalProduction
@@ -85,6 +87,12 @@ newDBLayer = do
         , readPoolRegistration =
             readPoolDB db . mReadPoolRegistration
 
+        , putPoolRetirement = \slot cert ->
+            void $ alterPoolDB (const Nothing) db $ mPutPoolRetirement slot cert
+
+        , readPoolRetirement =
+            readPoolDB db . mReadPoolRetirement
+
         , unfetchedPoolMetadataRefs =
             readPoolDB db . mUnfetchedPoolMetadataRefs
 

diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs
@@ -40,6 +40,8 @@ module Cardano.Pool.DB.Model
     , mReadPoolMetadata
     , mPutPoolRegistration
     , mReadPoolRegistration
+    , mPutPoolRetirement
+    , mReadPoolRetirement
     , mUnfetchedPoolMetadataRefs
     , mPutFetchAttempt
     , mPutPoolMetadata
@@ -57,6 +59,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolId
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
+    , PoolRetirementCertificate (..)
     , SlotId (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
@@ -98,6 +101,9 @@ data PoolDatabase = PoolDatabase
     , registrations :: !(Map (SlotId, PoolId) PoolRegistrationCertificate)
     -- ^ On-chain registrations associated with pools
 
+    , retirements :: !(Map (SlotId, PoolId) PoolRetirementCertificate)
+    -- ^ On-chain retirements associated with pools
+
     , metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
     -- ^ Off-chain metadata cached in database
 
@@ -122,7 +128,7 @@ instance Eq SystemSeed where
 -- | Produces an empty model pool production database.
 emptyPoolDatabase :: PoolDatabase
 emptyPoolDatabase =
-    PoolDatabase mempty mempty mempty mempty mempty mempty NotSeededYet
+    PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
 
 {-------------------------------------------------------------------------------
                                   Model Operation Types
@@ -202,6 +208,25 @@ mReadPoolRegistration poolId db@PoolDatabase{registrations} =
   where
     only k (_, k') _ = k == k'
 
+mPutPoolRetirement :: SlotId -> PoolRetirementCertificate -> ModelPoolOp ()
+mPutPoolRetirement sl retirement db@PoolDatabase {retirements} =
+    ( Right ()
+    , db { retirements = Map.insert (sl, poolId) retirement retirements }
+    )
+  where
+    PoolRetirementCertificate poolId _retiredIn = retirement
+
+mReadPoolRetirement :: PoolId -> ModelPoolOp (Maybe PoolRetirementCertificate)
+mReadPoolRetirement poolId db@PoolDatabase {retirements} =
+    ( Right
+        $ fmap snd
+        $ Map.lookupMax
+        $ Map.filterWithKey (only poolId) retirements
+    , db
+    )
+  where
+    only k (_, k') _ = k == k'
+
 mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase)
 mListRegisteredPools db@PoolDatabase{registrations} =
     ( snd <$> Map.keys registrations, db )
@@ -274,12 +299,14 @@ mRollbackTo point PoolDatabase { pools
                                , distributions
                                , owners
                                , registrations
+                               , retirements
                                , metadata
                                , seed
                                , fetchAttempts
                                } =
     let
         registrations' = Map.mapMaybeWithKey (discardBy id . fst) registrations
+        retirements' = Map.mapMaybeWithKey (discardBy id . fst) retirements
         owners' = Map.restrictKeys owners
             $ Set.fromList
             $ snd <$> Map.keys registrations'
@@ -291,6 +318,7 @@ mRollbackTo point PoolDatabase { pools
                 Map.mapMaybeWithKey (discardBy epochNumber) distributions
             , owners = owners'
             , registrations = registrations'
+            , retirements = retirements'
             , metadata
             , fetchAttempts
             , seed

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -50,6 +50,7 @@ import Cardano.Wallet.Primitive.Types
     , EpochNo (..)
     , PoolId
     , PoolRegistrationCertificate (..)
+    , PoolRetirementCertificate (..)
     , SlotId (..)
     , StakePoolMetadata (..)
     , StakePoolMetadataHash
@@ -250,6 +251,32 @@ newDBLayer trace fp = do
                         , poolMetadata
                         }
 
+        , putPoolRetirement = \slotId PoolRetirementCertificate
+            { poolId
+            , retiredIn
+            } -> do
+            let EpochNo retirementEpoch = retiredIn
+            repsert (PoolRetirementKey poolId slotId) $ PoolRetirement
+                poolId
+                slotId
+                (fromIntegral retirementEpoch)
+
+        , readPoolRetirement = \poolId -> do
+            let filterBy = [ PoolRetirementPoolId ==. poolId ]
+            let orderBy  = [ Desc PoolRetirementSlot ]
+            selectFirst filterBy orderBy >>= \case
+                Nothing -> pure Nothing
+                Just meta -> do
+                    let PoolRetirement
+                            _poolId
+                            _slotId
+                            retirementEpoch = entityVal meta
+                    let retiredIn = EpochNo (fromIntegral retirementEpoch)
+                    pure $ Just $ PoolRetirementCertificate
+                        { poolId
+                        , retiredIn
+                        }
+
         , unfetchedPoolMetadataRefs = \limit -> do
             let nLimit = T.pack (show limit)
             let metadataHash  = fieldName (DBField PoolRegistrationMetadataHash)