Merge #1847

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

# Related Issues

#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_.<br><br>

- [x] Adds the `PoolLifeCycleStatus` type, which indicates the current lifecycle stage of a pool.

    There are currently _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)<br><br>

- [x] Adds the `readPoolLifeCycleStatus` function to the pool DB layer, making it possible to determine the current lifecycle status 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 `determinePoolLifeCycleStatus` 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] `readPoolLifeCycleStatus` 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.

# 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-integration/src/Test/Integration/Framework/DSL.hs

@@ -610,10 +610,10 @@ eventuallyUsingDelay
     -> IO a
     -> IO a
 eventuallyUsingDelay delay desc io = do
-    winner <- race (threadDelay $ 180 * oneSecond) trial
+    winner <- race (threadDelay $ 300 * oneSecond) trial
     case winner of
         Left _ -> fail
-            ("waited more than 3min for action to eventually resolve.\
+            ("Waited more than 5 minutes for action to resolve.\
             \ Action: " ++ show desc)
         Right a ->
             return a

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 
 -- |
@@ -13,6 +14,9 @@ module Cardano.Pool.DB
     ( -- * Interface
       DBLayer (..)
 
+      -- * Utilities
+    , determinePoolLifeCycleStatus
+
       -- * Errors
     , ErrPointAlreadyExists (..)
     ) where
@@ -21,9 +25,12 @@ import Prelude
 
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader
+    , CertificatePublicationTime (..)
     , EpochNo (..)
     , PoolId
+    , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate
+    , 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
@@ -99,8 +108,13 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         --
         -- This is useful for the @NetworkLayer@ to know how far we have synced.
 
+    , readPoolLifeCycleStatus
+        :: PoolId
+        -> stm PoolLifeCycleStatus
+        -- ^ Read the current life cycle status of the given pool.
+
     , putPoolRegistration
-        :: SlotId
+        :: CertificatePublicationTime
         -> PoolRegistrationCertificate
         -> stm ()
         -- ^ Add a mapping between stake pools and their corresponding
@@ -109,8 +123,31 @@ 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,
+        -- together with the point in time that the certificate was added.
+        --
+        -- Note that a pool may also have other certificates associated with it
+        -- that affect its current lifecycle status.
+        --
+        -- See 'readPoolLifeCycleStatus'.
+
+    , 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,
+        -- together with the point in time that the certificate was added.
+        --
+        -- Note that a pool may also have other certificates associated with it
+        -- that affect its current lifecycle status.
+        --
+        -- See 'readPoolLifeCycleStatus'.
 
     , unfetchedPoolMetadataRefs
         :: Int
@@ -166,6 +203,72 @@ 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 life cycle 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
+--
+determinePoolLifeCycleStatus
+    :: (Ord publicationTime, Show publicationTime)
+    => Maybe (publicationTime, PoolRegistrationCertificate)
+    -> Maybe (publicationTime, PoolRetirementCertificate)
+    -> PoolLifeCycleStatus
+determinePoolLifeCycleStatus 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:"
+            , " determinePoolLifeCycleStatus:"
+            , " 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:"
+            , " determinePoolLifeCycleStatus:"
+            , " 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
+            ]
+
 -- | 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

@@ -17,7 +17,7 @@ module Cardano.Pool.DB.MVar
 import Prelude
 
 import Cardano.Pool.DB
-    ( DBLayer (..), ErrPointAlreadyExists (..) )
+    ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus )
 import Cardano.Pool.DB.Model
     ( ModelPoolOp
     , PoolDatabase
@@ -29,11 +29,13 @@ import Cardano.Pool.DB.Model
     , mPutPoolMetadata
     , mPutPoolProduction
     , mPutPoolRegistration
+    , mPutPoolRetirement
     , mPutStakeDistribution
     , mReadCursor
     , mReadPoolMetadata
     , mReadPoolProduction
     , mReadPoolRegistration
+    , mReadPoolRetirement
     , mReadStakeDistribution
     , mReadSystemSeed
     , mReadTotalProduction
@@ -58,6 +60,10 @@ import Data.Tuple
 newDBLayer :: IO (DBLayer IO)
 newDBLayer = do
     db <- newMVar emptyPoolDatabase
+    let readPoolRegistration_ =
+            readPoolDB db . mReadPoolRegistration
+    let readPoolRetirement_ =
+            readPoolDB db . mReadPoolRetirement
     return $ DBLayer
 
         { putPoolProduction = \sl pool -> ExceptT $ do
@@ -79,11 +85,22 @@ 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
+        , readPoolLifeCycleStatus = \poolId ->
+            determinePoolLifeCycleStatus
+                <$> readPoolRegistration_ poolId
+                <*> readPoolRetirement_ poolId
+
+        , readPoolRegistration = readPoolRegistration_
+
+        , putPoolRetirement = \cpt cert -> void
+            $ alterPoolDB (const Nothing) db
+            $ mPutPoolRetirement cpt cert
+
+        , readPoolRetirement = readPoolRetirement_
 
         , unfetchedPoolMetadataRefs =
             readPoolDB db . mUnfetchedPoolMetadataRefs