From 330f1c05f1690f2e11e8f0079ebab796685f1536 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 3 Jul 2020 08:58:31 +0000 Subject: [PATCH] Introduce `CertificatePublicationTime` type. The `CertificatePublicationTime` type represents an abstract notion of a certificate publication time. Certificates published at later times take precedence over certificates published at earlier times. --- lib/core/src/Cardano/Pool/DB.hs | 38 ++++++++++++++----- lib/core/src/Cardano/Pool/DB/Model.hs | 22 ++++++----- .../test/unit/Cardano/Pool/DB/Properties.hs | 6 +-- 3 files changed, 43 insertions(+), 23 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 5abeb49af36..79860eb7cbf 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -14,6 +14,7 @@ module Cardano.Pool.DB ( -- * Interface DBLayer (..) + , CertificatePublicationTime , PoolRegistrationStatus (..) , determinePoolRegistrationStatus , readPoolRegistrationStatus @@ -107,7 +108,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 - :: SlotIndex + :: CertificatePublicationTime -> PoolRegistrationCertificate -> stm () -- ^ Add a mapping between stake pools and their corresponding @@ -116,19 +117,21 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer , readPoolRegistration :: PoolId - -> stm (Maybe (SlotIndex, 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 - :: SlotIndex + :: CertificatePublicationTime -> PoolRetirementCertificate -> stm () -- ^ Add a retirement certificate for a particular pool. , readPoolRetirement :: PoolId - -> stm (Maybe (SlotIndex, PoolRetirementCertificate)) - -- ^ Find a retirement certificate for a particular pool. + -> 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 @@ -184,8 +187,18 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- For a Sqlite DB, this would be "run a query inside a transaction". } -type SlotIndex = (SlotId, SlotInternalIndex) +-- | Represents an abstract notion of a certificate publication time. +-- +-- Certificates published at later times take precedence over certificates +-- published at earlier times. +-- +type CertificatePublicationTime = (SlotId, SlotInternalIndex) +-- | Indicates the current registration status of a pool. +-- +-- Use the 'readPoolRegistrationStatus' function to query the registration +-- status for a particular pool and database backend. +-- data PoolRegistrationStatus = PoolNotRegistered -- ^ Indicates that a pool is not registered. @@ -199,9 +212,12 @@ data PoolRegistrationStatus -- ^ Indicates that a pool is registered AND ALSO marked for retirement. -- Records the latest registration and retirement certificates. +-- | 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. determinePoolRegistrationStatus - :: Maybe (SlotIndex, PoolRegistrationCertificate) - -> Maybe (SlotIndex, PoolRetirementCertificate) + :: Maybe (CertificatePublicationTime, PoolRegistrationCertificate) + -> Maybe (CertificatePublicationTime, PoolRetirementCertificate) -> PoolRegistrationStatus determinePoolRegistrationStatus = f where @@ -215,6 +231,10 @@ determinePoolRegistrationStatus = f | otherwise = PoolRegisteredAndRetired regCert retCert +-- | Reads the current registration status of a pool. +-- +-- See 'PoolRegistrationStatus' for more details. +-- readPoolRegistrationStatus :: DBLayer m -> PoolId diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 342e47048be..0eac8d1e277 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -53,6 +53,8 @@ module Cardano.Pool.DB.Model import Prelude +import Cardano.Pool.DB + ( CertificatePublicationTime ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) , EpochNo (..) @@ -61,7 +63,6 @@ import Cardano.Wallet.Primitive.Types , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , SlotId (..) - , SlotInternalIndex (..) , StakePoolMetadata , StakePoolMetadataHash , StakePoolMetadataUrl @@ -91,8 +92,6 @@ import qualified Data.Set as Set Model Database Types -------------------------------------------------------------------------------} -type SlotIndex = (SlotId, SlotInternalIndex) - data PoolDatabase = PoolDatabase { pools :: !(Map PoolId [BlockHeader]) -- ^ Information of what blocks were produced by which stake pools @@ -104,11 +103,11 @@ data PoolDatabase = PoolDatabase -- ^ Mapping between pool ids and owners , registrations - :: !(Map (SlotIndex, PoolId) PoolRegistrationCertificate) + :: !(Map (CertificatePublicationTime, PoolId) PoolRegistrationCertificate) -- ^ On-chain registrations associated with pools , retirements - :: !(Map (SlotIndex, PoolId) PoolRetirementCertificate) + :: !(Map (CertificatePublicationTime, PoolId) PoolRetirementCertificate) -- ^ On-chain retirements associated with pools , metadata :: !(Map StakePoolMetadataHash StakePoolMetadata) @@ -194,7 +193,7 @@ mReadStakeDistribution epoch db@PoolDatabase{distributions} = ) mPutPoolRegistration - :: SlotIndex + :: CertificatePublicationTime -> PoolRegistrationCertificate -> ModelPoolOp () mPutPoolRegistration sp registration db = @@ -209,7 +208,8 @@ mPutPoolRegistration sp registration db = mReadPoolRegistration :: PoolId - -> ModelPoolOp (Maybe (SlotIndex, PoolRegistrationCertificate)) + -> ModelPoolOp + (Maybe (CertificatePublicationTime, PoolRegistrationCertificate)) mReadPoolRegistration poolId db = ( Right $ fmap (first fst) @@ -222,7 +222,7 @@ mReadPoolRegistration poolId db = only k (_, k') _ = k == k' mPutPoolRetirement - :: SlotIndex + :: CertificatePublicationTime -> PoolRetirementCertificate -> ModelPoolOp () mPutPoolRetirement sp retirement db = @@ -235,7 +235,8 @@ mPutPoolRetirement sp retirement db = mReadPoolRetirement :: PoolId - -> ModelPoolOp (Maybe (SlotIndex, PoolRetirementCertificate)) + -> ModelPoolOp + (Maybe (CertificatePublicationTime, PoolRetirementCertificate)) mReadPoolRetirement poolId db = ( Right $ fmap (first fst) @@ -259,7 +260,8 @@ mUnfetchedPoolMetadataRefs n db@PoolDatabase{registrations,metadata} = , db ) where - unfetched :: Map (SlotIndex, PoolId) PoolRegistrationCertificate + unfetched + :: Map (CertificatePublicationTime, PoolId) PoolRegistrationCertificate unfetched = flip Map.filter registrations $ \r -> case poolMetadata r of Nothing -> False diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 9739b8bb58c..e7916969f93 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -16,7 +16,7 @@ import Cardano.BM.Trace import Cardano.DB.Sqlite ( DBLog (..), SqliteContext ) import Cardano.Pool.DB - ( DBLayer (..), ErrPointAlreadyExists (..) ) + ( CertificatePublicationTime, DBLayer (..), ErrPointAlreadyExists (..) ) import Cardano.Pool.DB.Arbitrary ( StakePoolsFixture (..), genStakePoolMetadata ) import Cardano.Pool.DB.Sqlite @@ -409,12 +409,10 @@ prop_poolRegistration DBLayer {..} entries = ] assert (pools == expected) -type SlotIndex = (SlotId, SlotInternalIndex) - prop_rollbackRegistration :: DBLayer IO -> SlotId - -> [(SlotIndex, PoolRegistrationCertificate)] + -> [(CertificatePublicationTime, PoolRegistrationCertificate)] -> Property prop_rollbackRegistration DBLayer{..} rollbackPoint entries = monadicIO (setup >> prop)