Merge #1847

1847: Track Stakepool Retirements in the DB r=jonathanknowles a=jonathanknowles

# Issue Number

#1815 
#1816 
#1817 
#1819 
#1880 

# Overview

This PR:

- [x] Extends the pool DB schema to make it possible to store:
    - [x] retirement certificates.
    - [x] the order of publication of certificates _within the same block_, for both registration and retirement certificates. This is necessary, as the intra-block order is _significant_.
- [x] Adds the `RegistrationStatus` type, which indicates the current registration and retirement status of a pool.
    There are _three_ possibilities:
    1. `NotRegistered`
        (indicates that a pool has never been registered)
    2. `Registered`
        (indicates that a pool has been registered but _not_ retired)
        (provides a registration certificate)
    3. `RegisteredAndRetired`
        (indicates that a pool has been registered _and_ retired)
        (provides both a registration and a retirement certificate)
- [x] Adds the `readRegistrationStatus` function to the pool DB layer, making it possible to determine the current `RegistrationStatus` of a pool. 
- [x] Updates the `retirement` field of `ApiStakePool` with live information.

# Property Tests

This PR adds property tests to ensure that:

- [x] the `determinePoolRegistrationStatus` function respects the correct order of precedence for registration and retirement certificates:
    - for a given pool, a registration certificate always _supercedes_ a prior retirement certificate.
    - for a given pool, a retirement certificate always _augments_ the latest registration certificate.
- [x] `readPoolRegistrationStatus` queries work correctly in the presence of blocks containing multiple certificates for the same pool.
- [x] database rollback works correctly in the presence of retirement certificates.
- [x] values of type `SlotInternalId` can be correctly written to and read from the database.

# Future Work

A **_future_** PR will add integration tests to ensure that:

- retiring a pool eventually results in a correct update to the `retirement` field of `ApiStakePool`, when read through the `ListStakePools` operation.
- retiring and then re-registering a pool clears the `retirement` field. 

See QA section of #1819.



Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>

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

@@ -1,6 +1,8 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- |
@@ -12,6 +14,8 @@
 module Cardano.Pool.DB
     ( -- * Interface
       DBLayer (..)
+    , determinePoolRegistrationStatus
+    , readPoolRegistrationStatus
 
       -- * Errors
     , ErrPointAlreadyExists (..)
@@ -21,9 +25,12 @@ import Prelude
 
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader
+    , CertificatePublicationTime (..)
     , EpochNo (..)
     , PoolId
     , PoolRegistrationCertificate
+    , PoolRegistrationStatus (..)
+    , PoolRetirementCertificate
     , SlotId (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
@@ -35,6 +42,8 @@ import Control.Monad.IO.Class
     ( MonadIO )
 import Control.Monad.Trans.Except
     ( ExceptT )
+import Data.Generics.Internal.VL.Lens
+    ( view )
 import Data.Map.Strict
     ( Map )
 import Data.Quantity
@@ -100,7 +109,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -- This is useful for the @NetworkLayer@ to know how far we have synced.
 
     , putPoolRegistration
-        :: SlotId
+        :: CertificatePublicationTime
         -> PoolRegistrationCertificate
         -> stm ()
         -- ^ Add a mapping between stake pools and their corresponding
@@ -109,8 +118,21 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
 
     , readPoolRegistration
         :: PoolId
-        -> stm (Maybe PoolRegistrationCertificate)
-        -- ^ Find a registration certificate associated to a given pool
+        -> stm (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
+        -- ^ Find the /latest/ registration certificate for the given pool,
+        -- along with the point in time that the certificate was added.
+
+    , putPoolRetirement
+        :: CertificatePublicationTime
+        -> PoolRetirementCertificate
+        -> stm ()
+        -- ^ Add a retirement certificate for a particular pool.
+
+    , readPoolRetirement
+        :: PoolId
+        -> stm (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
+        -- ^ Find the /latest/ retirement certificate for the given pool,
+        -- along with the point in time that the certificate was added.
 
     , unfetchedPoolMetadataRefs
         :: Int
@@ -166,6 +188,86 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -- For a Sqlite DB, this would be "run a query inside a transaction".
     }
 
+-- | Given the /latest/ registration and retirement certificates for a pool,
+--   determine the pool's current registration status based on the relative
+--   order in which the certificates were published.
+--
+-- If two certificates are supplied, then:
+--
+--   * the certificates must be from the same pool.
+--   * the publication times must be non-equal.
+--
+-- Violating either of the above pre-conditions is a programming error.
+--
+-- This function determines order of precedence according to the "pool
+-- inference rule", as described in "A Formal Specification of the Cardano
+-- Ledger":
+--
+-- https://hydra.iohk.io/build/3202141/download/1/ledger-spec.pdf
+--
+determinePoolRegistrationStatus
+    :: (Ord publicationTime, Show publicationTime)
+    => Maybe (publicationTime, PoolRegistrationCertificate)
+    -> Maybe (publicationTime, PoolRetirementCertificate)
+    -> PoolRegistrationStatus
+determinePoolRegistrationStatus mReg mRet = case (mReg, mRet) of
+    (Nothing, _) ->
+        PoolNotRegistered
+    (Just (_, regCert), Nothing) ->
+        PoolRegistered regCert
+    (Just (regTime, regCert), Just (retTime, retCert))
+        | regPoolId /= retPoolId ->
+            differentPoolsError
+        | regTime > retTime ->
+            -- A re-registration always /supercedes/ a prior retirement.
+            PoolRegistered regCert
+        | regTime < retTime ->
+            -- A retirement always /augments/ the latest known registration.
+            PoolRegisteredAndRetired regCert retCert
+        | otherwise ->
+            timeCollisionError
+      where
+        regPoolId = view #poolId regCert
+        retPoolId = view #poolId retCert
+
+        differentPoolsError = error $ mconcat
+            [ "programming error:"
+            , " determinePoolRegistrationStatus:"
+            , " called with certificates for different pools:"
+            , " pool id of registration certificate: "
+            , show regPoolId
+            , " pool id of retirement certificate: "
+            , show retPoolId
+            ]
+
+        timeCollisionError = error $ mconcat
+            [ "programming error:"
+            , " determinePoolRegistrationStatus:"
+            , " called with identical certificate publication times:"
+            , " pool id of registration certificate: "
+            , show regPoolId
+            , " pool id of retirement certificate: "
+            , show retPoolId
+            , " publication time of registration certificate: "
+            , show regTime
+            , " publication time of retirement certificate: "
+            , show retTime
+            ]
+
+-- | Reads the current registration status of a pool.
+--
+-- See 'PoolRegistrationStatus' for more details.
+--
+readPoolRegistrationStatus
+    :: DBLayer m
+    -> PoolId
+    -> m PoolRegistrationStatus
+readPoolRegistrationStatus
+    DBLayer {atomically, readPoolRegistration, readPoolRetirement} poolId =
+        atomically $ determinePoolRegistrationStatus
+            <$> readPoolRegistration poolId
+            <*> readPoolRetirement poolId
+
 -- | Forbidden operation was executed on an already existing slot
 newtype ErrPointAlreadyExists
     = ErrPointAlreadyExists BlockHeader -- Point already exists in db

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
@@ -79,12 +81,20 @@ newDBLayer = do
         , readPoolProductionCursor =
             readPoolDB db . mReadCursor
 
-        , putPoolRegistration = \a0 a1 ->
-            void $ alterPoolDB (const Nothing) db $ mPutPoolRegistration a0 a1
+        , putPoolRegistration = \cpt cert -> void
+              $ alterPoolDB (const Nothing) db
+              $ mPutPoolRegistration cpt cert
 
         , readPoolRegistration =
             readPoolDB db . mReadPoolRegistration
 
+        , putPoolRetirement = \cpt cert -> void
+            $ alterPoolDB (const Nothing) db
+            $ mPutPoolRetirement cpt cert
+
+        , readPoolRetirement =
+            readPoolDB db . mReadPoolRetirement
+
         , unfetchedPoolMetadataRefs =
             readPoolDB db . mUnfetchedPoolMetadataRefs
 

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

@@ -8,6 +8,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -40,6 +41,8 @@ module Cardano.Pool.DB.Model
     , mReadPoolMetadata
     , mPutPoolRegistration
     , mReadPoolRegistration
+    , mPutPoolRetirement
+    , mReadPoolRetirement
     , mUnfetchedPoolMetadataRefs
     , mPutFetchAttempt
     , mPutPoolMetadata
@@ -53,17 +56,23 @@ import Prelude
 
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
+    , CertificatePublicationTime
     , EpochNo (..)
     , PoolId
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
+    , PoolRetirementCertificate (..)
     , SlotId (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
     , StakePoolMetadataUrl
     )
+import Data.Bifunctor
+    ( first )
 import Data.Foldable
     ( fold )
+import Data.Generics.Internal.VL.Lens
+    ( view )
 import Data.Map.Strict
     ( Map )
 import Data.Ord
@@ -95,9 +104,14 @@ data PoolDatabase = PoolDatabase
     , owners :: !(Map PoolId [PoolOwner])
     -- ^ Mapping between pool ids and owners
 
-    , registrations :: !(Map (SlotId, PoolId) PoolRegistrationCertificate)
+    , registrations ::
+        !(Map (CertificatePublicationTime, PoolId) PoolRegistrationCertificate)
     -- ^ On-chain registrations associated with pools
 
+    , retirements ::
+        !(Map (CertificatePublicationTime, PoolId) PoolRetirementCertificate)
+    -- ^ On-chain retirements associated with pools
+
     , metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
     -- ^ Off-chain metadata cached in database
 
@@ -122,7 +136,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
@@ -180,22 +194,61 @@ mReadStakeDistribution epoch db@PoolDatabase{distributions} =
     , db
     )
 
-mPutPoolRegistration :: SlotId -> PoolRegistrationCertificate -> ModelPoolOp ()
-mPutPoolRegistration sl registration db@PoolDatabase{owners,registrations} =
+mPutPoolRegistration
+    :: CertificatePublicationTime
+    -> PoolRegistrationCertificate
+    -> ModelPoolOp ()
+mPutPoolRegistration cpt cert db =
     ( Right ()
-    , db { owners = Map.insert poolId poolOwners owners
-         , registrations = Map.insert (sl, poolId) registration registrations
-         }
+    , db
+        { owners = Map.insert poolId poolOwners owners
+        , registrations = Map.insert (cpt, poolId) cert registrations
+        }
+    )
+  where
+    PoolDatabase {owners, registrations} = db
+    PoolRegistrationCertificate {poolId, poolOwners} = cert
+
+mReadPoolRegistration
+    :: PoolId
+    -> ModelPoolOp
+        (Maybe (CertificatePublicationTime, PoolRegistrationCertificate))
+mReadPoolRegistration poolId db =
+    ( Right
+        $ fmap (first fst)
+        $ Map.lookupMax
+        $ Map.filterWithKey (only poolId) registrations
+    , db
     )
   where
-    PoolRegistrationCertificate { poolId , poolOwners } = registration
+    PoolDatabase {registrations} = db
+    only k (_, k') _ = k == k'
 
-mReadPoolRegistration :: PoolId -> ModelPoolOp (Maybe PoolRegistrationCertificate)
-mReadPoolRegistration poolId db@PoolDatabase{registrations} =
-    ( Right $ fmap snd $ Map.lookupMax $ Map.filterWithKey (only poolId) registrations
+mPutPoolRetirement
+    :: CertificatePublicationTime
+    -> PoolRetirementCertificate
+    -> ModelPoolOp ()
+mPutPoolRetirement cpt cert db =
+    ( Right ()
+    , db {retirements = Map.insert (cpt, poolId) cert retirements}
+    )
+  where
+    PoolDatabase {retirements} = db
+    PoolRetirementCertificate poolId _retiredIn = cert
+
+mReadPoolRetirement
+    :: PoolId
+    -> ModelPoolOp
+        (Maybe (CertificatePublicationTime, PoolRetirementCertificate))
+mReadPoolRetirement poolId db =
+    ( Right
+        $ fmap (first fst)
+        $ Map.lookupMax
+        $ Map.filterWithKey (only poolId) retirements
     , db
     )
   where
+    PoolDatabase {retirements} = db
     only k (_, k') _ = k == k'
 
 mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase)
@@ -210,7 +263,8 @@ mUnfetchedPoolMetadataRefs n db@PoolDatabase{registrations,metadata} =
     , db
     )
   where
-    unfetched :: Map (SlotId, PoolId) PoolRegistrationCertificate
+    unfetched
+        :: Map (CertificatePublicationTime, PoolId) PoolRegistrationCertificate
     unfetched = flip Map.filter registrations $ \r ->
         case poolMetadata r of
             Nothing -> False
@@ -270,22 +324,30 @@ mRollbackTo point PoolDatabase { pools
                                , distributions
                                , owners
                                , registrations
+                               , retirements
                                , metadata
                                , seed
                                , fetchAttempts
                                } =
     let
-        registrations' = Map.mapMaybeWithKey (discardBy id . fst) registrations
+        registrations' =
+            Map.mapMaybeWithKey
+                (discardBy id . view #slotId . fst) registrations
+        retirements' =
+            Map.mapMaybeWithKey
+                (discardBy id . view #slotId . fst) retirements
         owners' = Map.restrictKeys owners
             $ Set.fromList
             $ snd <$> Map.keys registrations'
     in
         ( Right ()
         , PoolDatabase
             { pools = updatePools $ updateSlots pools
-            , distributions = Map.mapMaybeWithKey (discardBy epochNumber) distributions
+            , distributions =
+                Map.mapMaybeWithKey (discardBy epochNumber) distributions
             , owners = owners'
             , registrations = registrations'
+            , retirements = retirements'
             , metadata
             , fetchAttempts
             , seed