diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index b1f880d88a2..fa19f7e5d50 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/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 diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index 79cee401fdf..c905f6c8a11 100644 --- 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 @@ -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 diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 090d3ab1706..3566c81effe 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/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,12 +324,18 @@ 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' @@ -283,9 +343,11 @@ mRollbackTo point PoolDatabase { pools ( 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 diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 440584c09d0..962dc0e7a63 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -46,9 +47,11 @@ import Cardano.Wallet.DB.Sqlite.Types ( BlockId (..) ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) + , CertificatePublicationTime (..) , EpochNo (..) , PoolId , PoolRegistrationCertificate (..) + , PoolRetirementCertificate (..) , SlotId (..) , StakePoolMetadata (..) , StakePoolMetadataHash @@ -57,6 +60,8 @@ import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) import Control.Exception ( bracket, throwIO ) +import Control.Monad + ( forM ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except @@ -65,6 +70,8 @@ import Control.Tracer ( Tracer, traceWith ) import Data.Either ( rights ) +import Data.Generics.Internal.VL.Lens + ( view ) import Data.List ( foldl' ) import Data.Map.Strict @@ -196,55 +203,64 @@ newDBLayer trace fp = do [ StakeDistributionEpoch ==. fromIntegral epoch ] [] - , putPoolRegistration = \point PoolRegistrationCertificate - { poolId - , poolOwners - , poolMargin - , poolCost - , poolPledge - , poolMetadata - } -> do - let poolMarginN = fromIntegral $ numerator $ getPercentage poolMargin - let poolMarginD = fromIntegral $ denominator $ getPercentage poolMargin - let poolCost_ = getQuantity poolCost - let poolPledge_ = getQuantity poolPledge - let poolMetadataUrl = fst <$> poolMetadata - let poolMetadataHash = snd <$> poolMetadata - deleteWhere [PoolOwnerPoolId ==. poolId, PoolOwnerSlot ==. point] - _ <- repsert (PoolRegistrationKey poolId point) $ PoolRegistration - poolId - point - poolMarginN - poolMarginD - poolCost_ - poolPledge_ - poolMetadataUrl - poolMetadataHash - insertMany_ $ zipWith (PoolOwner poolId point) poolOwners [0..] + , putPoolRegistration = \cpt cert -> do + let CertificatePublicationTime {slotId, slotInternalIndex} = cpt + let poolId = view #poolId cert + deleteWhere [PoolOwnerPoolId ==. poolId, PoolOwnerSlot ==. slotId] + let poolRegistrationKey = PoolRegistrationKey + poolId slotId slotInternalIndex + let poolRegistrationRow = PoolRegistration + (poolId) + (slotId) + (slotInternalIndex) + (fromIntegral $ numerator + $ getPercentage $ poolMargin cert) + (fromIntegral $ denominator + $ getPercentage $ poolMargin cert) + (getQuantity $ poolCost cert) + (getQuantity $ poolPledge cert) + (fst <$> poolMetadata cert) + (snd <$> poolMetadata cert) + _ <- repsert poolRegistrationKey poolRegistrationRow + insertMany_ $ + zipWith + (PoolOwner poolId slotId slotInternalIndex) + (poolOwners cert) + [0..] , readPoolRegistration = \poolId -> do - let filterBy = [ PoolRegistrationPoolId ==. poolId ] - let orderBy = [ Desc PoolRegistrationSlot ] - selectFirst filterBy orderBy >>= \case - Nothing -> pure Nothing - Just meta -> do - let PoolRegistration - _poolId - _point - marginNum - marginDen - poolCost_ - poolPledge_ - poolMetadataUrl - poolMetadataHash = entityVal meta - let poolMargin = unsafeMkPercentage $ toRational $ marginNum % marginDen - let poolCost = Quantity poolCost_ - let poolPledge = Quantity poolPledge_ - let poolMetadata = (,) <$> poolMetadataUrl <*> poolMetadataHash - poolOwners <- fmap (poolOwnerOwner . entityVal) <$> selectList - [ PoolOwnerPoolId ==. poolId ] - [ Desc PoolOwnerSlot, Asc PoolOwnerIndex ] - pure $ Just $ PoolRegistrationCertificate + result <- selectFirst + [ PoolRegistrationPoolId ==. poolId ] + [ Desc PoolRegistrationSlot + , Desc PoolRegistrationSlotInternalIndex + ] + forM result $ \meta -> do + let PoolRegistration + _poolId + slotId + slotInternalIndex + marginNum + marginDen + poolCost_ + poolPledge_ + poolMetadataUrl + poolMetadataHash = entityVal meta + let poolMargin = unsafeMkPercentage $ + toRational $ marginNum % marginDen + let poolCost = Quantity poolCost_ + let poolPledge = Quantity poolPledge_ + let poolMetadata = (,) <$> poolMetadataUrl <*> poolMetadataHash + poolOwners <- fmap (poolOwnerOwner . entityVal) <$> + selectList + [ PoolOwnerPoolId + ==. poolId + , PoolOwnerSlot + ==. slotId + , PoolOwnerSlotInternalIndex + ==. slotInternalIndex + ] + [ Asc PoolOwnerIndex ] + let cert = PoolRegistrationCertificate { poolId , poolOwners , poolMargin @@ -252,6 +268,39 @@ newDBLayer trace fp = do , poolPledge , poolMetadata } + let cpt = CertificatePublicationTime {slotId, slotInternalIndex} + pure (cpt, cert) + + , putPoolRetirement = \cpt cert -> do + let CertificatePublicationTime {slotId, slotInternalIndex} = cpt + let PoolRetirementCertificate + { poolId + , retiredIn + } = cert + let EpochNo retirementEpoch = retiredIn + repsert (PoolRetirementKey poolId slotId slotInternalIndex) $ + PoolRetirement + poolId + slotId + slotInternalIndex + (fromIntegral retirementEpoch) + + , readPoolRetirement = \poolId -> do + result <- selectFirst + [ PoolRetirementPoolId ==. poolId ] + [ Desc PoolRetirementSlot + , Desc PoolRetirementSlotInternalIndex + ] + forM result $ \meta -> do + let PoolRetirement + _poolId + slotId + slotInternalIndex + retirementEpoch = entityVal meta + let retiredIn = EpochNo (fromIntegral retirementEpoch) + let cert = PoolRetirementCertificate {poolId, retiredIn} + let cpt = CertificatePublicationTime {slotId, slotInternalIndex} + pure (cpt, cert) , unfetchedPoolMetadataRefs = \limit -> do let nLimit = T.pack (show limit) @@ -329,6 +378,7 @@ newDBLayer trace fp = do deleteWhere [ PoolProductionSlot >. point ] deleteWhere [ StakeDistributionEpoch >. fromIntegral epoch ] deleteWhere [ PoolRegistrationSlot >. point ] + deleteWhere [ PoolRetirementSlot >. point ] -- TODO: remove dangling metadata no longer attached to a pool , readPoolProductionCursor = \k -> do @@ -350,6 +400,7 @@ newDBLayer trace fp = do deleteWhere ([] :: [Filter PoolProduction]) deleteWhere ([] :: [Filter PoolOwner]) deleteWhere ([] :: [Filter PoolRegistration]) + deleteWhere ([] :: [Filter PoolRetirement]) deleteWhere ([] :: [Filter StakeDistribution]) deleteWhere ([] :: [Filter PoolMetadata]) deleteWhere ([] :: [Filter PoolMetadataFetchAttempts]) @@ -425,7 +476,7 @@ mkPoolProduction -> PoolProduction mkPoolProduction pool block = PoolProduction { poolProductionPoolId = pool - , poolProductionSlot = slotId block + , poolProductionSlot = view #slotId block , poolProductionHeaderHash = BlockId (headerHash block) , poolProductionParentHash = BlockId (parentHeaderHash block) , poolProductionBlockHeight = getQuantity (blockHeight block) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs index 306cbeaec4f..9fe1abfa42b 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs @@ -75,27 +75,39 @@ StakeDistribution sql=stake_distribution -- Mapping from pool id to owner. PoolOwner sql=pool_owner - poolOwnerPoolId W.PoolId sql=pool_id - poolOwnerSlot W.SlotId sql=slot - poolOwnerOwner W.PoolOwner sql=pool_owner - poolOwnerIndex Word8 sql=pool_owner_index - - Primary poolOwnerPoolId poolOwnerSlot poolOwnerOwner poolOwnerIndex - Foreign PoolRegistration fk_registration_pool_id poolOwnerPoolId poolOwnerSlot ! ON DELETE CASCADE + poolOwnerPoolId W.PoolId sql=pool_id + poolOwnerSlot W.SlotId sql=slot + poolOwnerSlotInternalIndex Word64 sql=slot_internal_index + poolOwnerOwner W.PoolOwner sql=pool_owner + poolOwnerIndex Word8 sql=pool_owner_index + + Primary poolOwnerPoolId poolOwnerSlot poolOwnerSlotInternalIndex poolOwnerOwner poolOwnerIndex + Foreign PoolRegistration fk_registration_pool_id poolOwnerPoolId poolOwnerSlot poolOwnerSlotInternalIndex ! ON DELETE CASCADE deriving Show Generic -- Mapping of registration certificate to pool PoolRegistration sql=pool_registration - poolRegistrationPoolId W.PoolId sql=pool_id - poolRegistrationSlot W.SlotId sql=slot - poolRegistrationMarginNumerator Word64 sql=margin_numerator - poolRegistrationMarginDenominator Word64 sql=margin_denominator - poolRegistrationCost Word64 sql=cost - poolRegistrationPledge Word64 sql=pledge - poolRegistrationMetadataUrl W.StakePoolMetadataUrl Maybe sql=metadata_url - poolRegistrationMetadataHash W.StakePoolMetadataHash Maybe sql=metadata_hash - - Primary poolRegistrationPoolId poolRegistrationSlot + poolRegistrationPoolId W.PoolId sql=pool_id + poolRegistrationSlot W.SlotId sql=slot + poolRegistrationSlotInternalIndex Word64 sql=slot_internal_index + poolRegistrationMarginNumerator Word64 sql=margin_numerator + poolRegistrationMarginDenominator Word64 sql=margin_denominator + poolRegistrationCost Word64 sql=cost + poolRegistrationPledge Word64 sql=pledge + poolRegistrationMetadataUrl W.StakePoolMetadataUrl Maybe sql=metadata_url + poolRegistrationMetadataHash W.StakePoolMetadataHash Maybe sql=metadata_hash + + Primary poolRegistrationPoolId poolRegistrationSlot poolRegistrationSlotInternalIndex + deriving Show Generic + +-- Mapping of retirement certificates to pools +PoolRetirement sql=pool_retirement + poolRetirementPoolId W.PoolId sql=pool_id + poolRetirementSlot W.SlotId sql=slot + poolRetirementSlotInternalIndex Word64 sql=slot_internal_index + poolRetirementEpoch Word64 sql=epoch + + Primary poolRetirementPoolId poolRetirementSlot poolRetirementSlotInternalIndex deriving Show Generic -- Cached metadata after they've been fetched from a remote server. diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 02c3b2afbdb..e54ac079610 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -57,10 +57,12 @@ module Cardano.Wallet.Primitive.Types , AddressState (..) -- * Delegation and stake pools + , CertificatePublicationTime (..) , ChimericAccount (..) , DelegationCertificate (..) , dlgCertAccount , dlgCertPoolId + , PoolRegistrationStatus (..) , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , PoolCertificate (..) @@ -1726,7 +1728,6 @@ dlgCertPoolId = \case CertDelegateFull _ poolId -> Just poolId CertRegisterKey _ -> Nothing - -- | Sum-type of pool registration- and retirement- certificates. Mirrors the -- @PoolCert@ type in cardano-ledger-specs. data PoolCertificate @@ -1771,6 +1772,38 @@ instance Buildable PoolRetirementCertificate where <> " retiring at " <> build e +-- | Represents an abstract notion of a certificate publication time. +-- +-- Certificates published at later times take precedence over certificates +-- published at earlier times. +-- +data CertificatePublicationTime = CertificatePublicationTime + { slotId + :: SlotId + , slotInternalIndex + :: Word64 + -- ^ Indicates the relative position of a publication within a slot. + } + deriving (Eq, Generic, Ord, Show) + +-- | 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. + | PoolRegistered + PoolRegistrationCertificate + -- ^ Indicates that a pool is registered BUT NOT marked for retirement. + -- Records the latest registration certificate. + | PoolRegisteredAndRetired + PoolRegistrationCertificate + PoolRetirementCertificate + -- ^ Indicates that a pool is registered AND ALSO marked for retirement. + -- Records the latest registration and retirement certificates. + deriving (Eq, Show) {------------------------------------------------------------------------------- Polymorphic Types diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 04c914bea0a..82ec3f9a464 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLabels #-} @@ -18,12 +19,15 @@ import Cardano.Wallet.Gen ( genPercentage ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) + , CertificatePublicationTime (..) , EpochLength (..) , EpochNo (..) , Hash (..) + , PoolCertificate (..) , PoolId (..) , PoolOwner (..) , PoolRegistrationCertificate (..) + , PoolRetirementCertificate (..) , SlotId (..) , SlotNo (..) , SlotParameters (..) @@ -58,6 +62,7 @@ import Test.QuickCheck , arbitrarySizedBoundedIntegral , choose , elements + , genericShrink , listOf , oneof , scale @@ -89,6 +94,10 @@ genPrintableText = T.pack . getPrintableString <$> arbitrary Stake Pools -------------------------------------------------------------------------------} +instance Arbitrary CertificatePublicationTime where + arbitrary = CertificatePublicationTime <$> arbitrary <*> arbitrary + shrink = genericShrink + instance Arbitrary SlotId where shrink (SlotId ep sl) = uncurry SlotId <$> shrink (ep, sl) @@ -150,6 +159,21 @@ instance Arbitrary PoolRegistrationCertificate where extP <- elements [ ".io", ".dev", ".com", ".eu" ] pure $ protocol <> "://" <> fstP <> "-" <> sndP <> extP +instance Arbitrary PoolRetirementCertificate where + arbitrary = PoolRetirementCertificate + <$> arbitrary + <*> arbitrary + shrink = genericShrink + +instance Arbitrary PoolCertificate where + arbitrary = oneof + [ Registration + <$> arbitrary + , Retirement + <$> arbitrary + ] + shrink = const [] + instance Arbitrary StakePoolMetadataHash where arbitrary = fmap (StakePoolMetadataHash . BS.pack) (vector 32) diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index 0254f366414..1640dbf2dcf 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -1,7 +1,12 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.Pool.DB.Properties ( properties @@ -16,22 +21,33 @@ import Cardano.BM.Trace import Cardano.DB.Sqlite ( DBLog (..), SqliteContext ) import Cardano.Pool.DB - ( DBLayer (..), ErrPointAlreadyExists (..) ) + ( DBLayer (..) + , ErrPointAlreadyExists (..) + , determinePoolRegistrationStatus + , readPoolRegistrationStatus + ) import Cardano.Pool.DB.Arbitrary ( StakePoolsFixture (..), genStakePoolMetadata ) import Cardano.Pool.DB.Sqlite ( newDBLayer ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) + , CertificatePublicationTime (..) , EpochNo + , PoolCertificate (..) , PoolId , PoolRegistrationCertificate (..) + , PoolRegistrationStatus (..) + , PoolRetirementCertificate (..) , SlotId (..) + , slotMinBound ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) import Control.Arrow ( second ) +import Control.Exception + ( evaluate ) import Control.Monad ( forM_, replicateM, unless ) import Control.Monad.IO.Class @@ -39,15 +55,17 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Except ( runExceptT ) import Data.Function - ( on ) + ( on, (&) ) import Data.Functor ( ($>) ) +import Data.Generics.Internal.VL.Lens + ( set, view ) import Data.List.Extra ( nubOrd ) import Data.Map.Strict ( Map ) import Data.Maybe - ( catMaybes, mapMaybe ) + ( catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe ) import Data.Ord ( Down (..) ) import Data.Quantity @@ -62,15 +80,25 @@ import Test.Hspec ( Expectation , Spec , SpecWith + , anyException , beforeAll , beforeWith , describe , it , shouldBe , shouldReturn + , shouldThrow ) import Test.QuickCheck - ( Positive (..), Property, classify, counterexample, property, (==>) ) + ( Positive (..) + , Property + , checkCoverage + , classify + , counterexample + , cover + , property + , (==>) + ) import Test.QuickCheck.Monadic ( PropertyM, assert, monadicIO, monitor, pick, run ) @@ -130,8 +158,20 @@ properties = do (property . prop_putStakeReadStake) it "putPoolRegistration then readPoolRegistration yields expected result" (property . prop_poolRegistration) + it "putPoolRetirement then readPoolRetirement yields expected result" + (property . prop_poolRetirement) + it "prop_multiple_putPoolRegistration_single_readPoolRegistration" + (property . + prop_multiple_putPoolRegistration_single_readPoolRegistration) + it "prop_multiple_putPoolRetirement_single_readPoolRetirement" + (property . + prop_multiple_putPoolRetirement_single_readPoolRetirement) + it "readPoolRegistrationStatus should respect registration order" + (property . prop_readPoolRegistrationStatus) it "rollback of PoolRegistration" (property . prop_rollbackRegistration) + it "rollback of PoolRetirement" + (property . prop_rollbackRetirement) it "readStake . putStake a1 . putStake s0 == pure a1" (property . prop_putStakePutStake) it "readSystemSeed is idempotent" @@ -144,6 +184,15 @@ properties = do (property . prop_unfetchedPoolMetadataRefs) it "unfetchedPoolMetadataRefsIgnoring" (property . prop_unfetchedPoolMetadataRefsIgnoring) + it "prop_determinePoolRegistrationStatus_orderCorrect" + (property . const + prop_determinePoolRegistrationStatus_orderCorrect) + it "prop_determinePoolRegistrationStatus_neverRegistered" + (property . const + prop_determinePoolRegistrationStatus_neverRegistered) + it "prop_determinePoolRegistrationStatus_differentPools" + (property . const + prop_determinePoolRegistrationStatus_differentPools) {------------------------------------------------------------------------------- Properties @@ -276,15 +325,15 @@ prop_readPoolNoEpochLeaks DBLayer{..} (StakePoolsFixture pairs _) = where slotPartition = L.groupBy ((==) `on` epochNumber) $ L.sortOn epochNumber - $ map (slotId . snd) pairs + $ map (view #slotId . snd) pairs epochGroups = L.zip (uniqueEpochs pairs) slotPartition setup = liftIO $ atomically cleanDB prop = run $ do atomically $ forM_ pairs $ \(pool, slot) -> unsafeRunExceptT $ putPoolProduction slot pool forM_ epochGroups $ \(epoch, slots) -> do - slots' <- (Set.fromList . map slotId . concat . Map.elems) <$> - atomically (readPoolProduction epoch) + slots' <- Set.fromList . map (view #slotId) . concat . Map.elems + <$> atomically (readPoolProduction epoch) slots' `shouldBe` (Set.fromList slots) -- | Read pool production satisfies conditions after consecutive @@ -298,7 +347,7 @@ prop_readPoolCondAfterDeterministicRollbacks cond DBLayer{..} (StakePoolsFixture monadicIO (setup >> prop) where setup = liftIO $ atomically cleanDB - slots = map (slotId . snd) pairs + slots = map (view #slotId . snd) pairs prop = run $ do atomically $ forM_ pairs $ \(pool, point) -> unsafeRunExceptT $ putPoolProduction point pool @@ -387,30 +436,246 @@ prop_putStakePutStake DBLayer {..} epoch a b = monitor $ classify (null a && null b) "a & b are empty" assert (L.sort res == L.sort b) --- | Heavily relies on the fact that PoolId have a entropy that is sufficient +-- | Heavily relies upon the fact that generated values of 'PoolId' are unique. prop_poolRegistration :: DBLayer IO - -> [PoolRegistrationCertificate] + -> [(CertificatePublicationTime, PoolRegistrationCertificate)] -> Property prop_poolRegistration DBLayer {..} entries = monadicIO (setup >> prop) where setup = run $ atomically cleanDB - expected = L.sort entries + entriesIn = L.sort entries prop = do - run . atomically $ mapM_ (putPoolRegistration (SlotId 0 0)) entries - pools <- run . atomically $ L.sort . catMaybes - <$> mapM (readPoolRegistration . poolId) entries + run $ atomically $ + mapM_ (uncurry putPoolRegistration) entriesIn + entriesOut <- run . atomically $ L.sort . catMaybes + <$> mapM (readPoolRegistration . view #poolId . snd) entries monitor $ counterexample $ unlines - [ "Read from DB: " <> show pools - , "Expected : " <> show expected + [ "Written into DB: " + , show entriesIn + , "Read from DB: " + , show entriesOut + ] + assert (entriesIn == entriesOut) + +-- | Heavily relies upon the fact that generated values of 'PoolId' are unique. +prop_poolRetirement + :: DBLayer IO + -> [(CertificatePublicationTime, PoolRetirementCertificate)] + -> Property +prop_poolRetirement DBLayer {..} entries = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + entriesIn = L.sort entries + prop = do + run $ atomically $ + mapM_ (uncurry putPoolRetirement) entriesIn + entriesOut <- run . atomically $ L.sort . catMaybes + <$> mapM (readPoolRetirement . view #poolId . snd) entries + monitor $ counterexample $ unlines + [ "Written into DB: " + , show entriesIn + , "Read from DB: " + , show entriesOut + ] + assert (entriesIn == entriesOut) + +-- For the same pool, write /multiple/ pool registration certificates to the +-- database and then read back the current registration certificate, verifying +-- that the certificate returned is the last one to have been written. +-- +prop_multiple_putPoolRegistration_single_readPoolRegistration + :: DBLayer IO + -> PoolId + -> [PoolRegistrationCertificate] + -> Property +prop_multiple_putPoolRegistration_single_readPoolRegistration + DBLayer {..} sharedPoolId certificatesManyPoolIds = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + prop = do + run $ atomically $ + mapM_ (uncurry putPoolRegistration) certificatePublications + mRetrievedCertificatePublication <- + run $ atomically $ readPoolRegistration sharedPoolId + monitor $ counterexample $ unlines + [ "\nExpected certificate publication: " + , show mExpectedCertificatePublication + , "\nRetrieved certificate publication: " + , show mRetrievedCertificatePublication + , "\nNumber of certificate publications: " + , show (length certificatePublications) + , "\nAll certificate publications: " + , unlines (("\n" <>) . show <$> certificatePublications) ] - assert (pools == expected) + assert $ (==) + mRetrievedCertificatePublication + mExpectedCertificatePublication + + certificatePublications + :: [(CertificatePublicationTime, PoolRegistrationCertificate)] + certificatePublications = publicationTimes `zip` certificates + + mExpectedCertificatePublication = certificatePublications + & reverse + & listToMaybe + + publicationTimes = + [ CertificatePublicationTime (SlotId en sn) ii + | en <- [0 ..] + , sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + + certificates = set #poolId sharedPoolId <$> certificatesManyPoolIds + +-- For the same pool, write /multiple/ pool retirement certificates to the +-- database and then read back the current retirement certificate, verifying +-- that the certificate returned is the last one to have been written. +-- +prop_multiple_putPoolRetirement_single_readPoolRetirement + :: DBLayer IO + -> PoolId + -> [PoolRetirementCertificate] + -> Property +prop_multiple_putPoolRetirement_single_readPoolRetirement + DBLayer {..} sharedPoolId certificatesManyPoolIds = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + prop = do + run $ atomically $ + mapM_ (uncurry putPoolRetirement) certificatePublications + mRetrievedCertificatePublication <- + run $ atomically $ readPoolRetirement sharedPoolId + monitor $ counterexample $ unlines + [ "\nExpected certificate publication: " + , show mExpectedCertificatePublication + , "\nRetrieved certificate publication: " + , show mRetrievedCertificatePublication + , "\nNumber of certificate publications: " + , show (length certificatePublications) + , "\nAll certificate publications: " + , unlines (("\n" <>) . show <$> certificatePublications) + ] + assert $ (==) + mRetrievedCertificatePublication + mExpectedCertificatePublication + + certificatePublications + :: [(CertificatePublicationTime, PoolRetirementCertificate)] + certificatePublications = publicationTimes `zip` certificates + + mExpectedCertificatePublication = certificatePublications + & reverse + & listToMaybe + + publicationTimes = + [ CertificatePublicationTime (SlotId en sn) ii + | en <- [0 ..] + , sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + + certificates = set #poolId sharedPoolId <$> certificatesManyPoolIds + +-- After writing an /arbitrary/ sequence of interleaved registration and +-- retirement certificates for the same pool to the database, verify that +-- reading the current registration status returns a result that reflects +-- the correct order of precedence for these certificates. +-- +-- Note that this property /assumes/ the correctness of the pure function +-- 'determinePoolRegistrationStatus', which is tested /elsewhere/ with +-- the @prop_determinePoolRegistrationStatus@ series of properties. +-- +prop_readPoolRegistrationStatus + :: DBLayer IO + -> PoolId + -> [PoolCertificate] + -> Property +prop_readPoolRegistrationStatus + db@DBLayer {..} sharedPoolId certificatesManyPoolIds = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + expectedStatus = determinePoolRegistrationStatus + mFinalRegistration + mFinalRetirement + + prop = do + run $ atomically $ + mapM_ (uncurry putCertificate) certificatePublications + actualStatus <- run $ readPoolRegistrationStatus db sharedPoolId + monitor $ counterexample $ unlines + [ "\nFinal registration: " + , show mFinalRegistration + , "\nFinal retirement: " + , show mFinalRetirement + , "\nExpected status: " + , show expectedStatus + , "\nActual status: " + , show actualStatus + , "\nNumber of certificate publications: " + , show (length certificatePublications) + , "\nAll certificate publications: " + , unlines (("\n" <>) . show <$> certificatePublications) + ] + assert (actualStatus == expectedStatus) + + certificatePublications :: [(CertificatePublicationTime, PoolCertificate)] + certificatePublications = publicationTimes `zip` certificates + + mFinalRegistration = certificatePublications + & reverse + & fmap (traverse toRegistrationCertificate) + & catMaybes + & listToMaybe + + mFinalRetirement = certificatePublications + & reverse + & fmap (traverse toRetirementCertificate) + & catMaybes + & listToMaybe + + publicationTimes = + [ CertificatePublicationTime (SlotId en sn) ii + | en <- [0 ..] + , sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + + certificates = setPoolId sharedPoolId <$> certificatesManyPoolIds + + toRegistrationCertificate = \case + Registration cert -> Just cert + Retirement _ -> Nothing + + toRetirementCertificate = \case + Retirement cert -> Just cert + Registration _ -> Nothing + + putCertificate cpt = \case + Registration cert -> + putPoolRegistration cpt cert + Retirement cert -> + putPoolRetirement cpt cert + + setPoolId newPoolId = \case + Registration cert -> Registration + $ set #poolId newPoolId cert + Retirement cert -> Retirement + $ set #poolId newPoolId cert prop_rollbackRegistration :: DBLayer IO -> SlotId - -> [(SlotId, PoolRegistrationCertificate)] + -> [(CertificatePublicationTime, PoolRegistrationCertificate)] -> Property prop_rollbackRegistration DBLayer{..} rollbackPoint entries = monadicIO (setup >> prop) @@ -418,10 +683,10 @@ prop_rollbackRegistration DBLayer{..} rollbackPoint entries = setup = run $ atomically cleanDB beforeRollback pool = do - case L.find (on (==) poolId pool . snd) entries of + case L.find (on (==) (view #poolId) pool . snd) entries of Nothing -> error "unknown pool?" - Just (sl, pool') -> + Just (CertificatePublicationTime sl _, pool') -> (sl <= rollbackPoint) && (pool == pool') ownerHasManyPools = @@ -431,8 +696,8 @@ prop_rollbackRegistration DBLayer{..} rollbackPoint entries = prop = do run . atomically $ mapM_ (uncurry putPoolRegistration) entries run . atomically $ rollbackTo rollbackPoint - pools <- run . atomically $ L.sort . catMaybes - <$> mapM (readPoolRegistration . poolId . snd) entries + pools <- run . atomically $ L.sort . fmap snd . catMaybes + <$> mapM (readPoolRegistration . (view #poolId) . snd) entries monitor $ classify (length pools < length entries) "rolled back some" monitor $ classify ownerHasManyPools "owner has many pools" monitor $ counterexample $ unlines @@ -440,6 +705,85 @@ prop_rollbackRegistration DBLayer{..} rollbackPoint entries = ] assert (all beforeRollback pools) +-- Verify that retirement certificates are correctly rolled back. +-- +prop_rollbackRetirement + :: DBLayer IO + -> [PoolRetirementCertificate] + -> Property +prop_rollbackRetirement DBLayer{..} certificates = + checkCoverage + $ cover 4 (rollbackPoint == slotMinBound) + "rollbackPoint = slotMinBound" + $ cover 4 (rollbackPoint > slotMinBound) + "rollbackPoint > slotMinBound" + $ cover 4 (null expectedPublications) + "length expectedPublications = 0" + $ cover 4 (not (null expectedPublications)) + "length expectedPublications > 0" + $ cover 4 + ( (&&) + (not (null expectedPublications)) + (length expectedPublications < length allPublications) + ) + "0 < length expectedPublications < length allPublications" + $ monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + prop = do + run $ atomically $ + mapM_ (uncurry putPoolRetirement) allPublications + run $ atomically $ rollbackTo rollbackPoint + retrievedPublications <- catMaybes <$> + run (atomically $ mapM readPoolRetirement poolIds) + monitor $ counterexample $ unlines + [ "\nRollback point: " + , show rollbackPoint + , "\nAll certificate publications: " + , unlines (("\n" <>) . show <$> allPublications) + , "\nExpected certificate publications: " + , unlines (("\n" <>) . show <$> expectedPublications) + , "\nRetrieved certificate publications: " + , unlines (("\n" <>) . show <$> retrievedPublications) + ] + assert $ (==) + retrievedPublications + expectedPublications + + poolIds :: [PoolId] + poolIds = view #poolId <$> certificates + + rollbackPoint :: SlotId + rollbackPoint = + -- Pick a slot that approximately corresponds to the midpoint of the + -- certificate publication list. + publicationTimes + & drop (length certificates `div` 2) + & fmap (view #slotId) + & listToMaybe + & fromMaybe slotMinBound + + allPublications + :: [(CertificatePublicationTime, PoolRetirementCertificate)] + allPublications = publicationTimes `zip` certificates + + expectedPublications + :: [(CertificatePublicationTime, PoolRetirementCertificate)] + expectedPublications = + filter + (\(CertificatePublicationTime slotId _, _) -> + slotId <= rollbackPoint) + allPublications + + publicationTimes :: [CertificatePublicationTime] + publicationTimes = + [ CertificatePublicationTime (SlotId en sn) ii + | en <- [0 ..] + , sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + prop_listRegisteredPools :: DBLayer IO -> [PoolRegistrationCertificate] @@ -453,7 +797,11 @@ prop_listRegisteredPools DBLayer {..} entries = L.nub poolOwners /= poolOwners prop = do - let entries' = (zip [SlotId ep 0 | ep <- [0..]] entries) + let entries' = + [ CertificatePublicationTime (SlotId ep 0) minBound + | ep <- [0 ..] + ] + `zip` entries run . atomically $ mapM_ (uncurry putPoolRegistration) entries' pools <- run . atomically $ listRegisteredPools monitor $ classify (any hasDuplicateOwners entries) @@ -461,7 +809,7 @@ prop_listRegisteredPools DBLayer {..} entries = monitor $ counterexample $ unlines [ "Read from DB: " <> show pools ] - assert (pools == (poolId <$> reverse entries)) + assert (pools == (view #poolId <$> reverse entries)) prop_unfetchedPoolMetadataRefs :: DBLayer IO @@ -472,7 +820,11 @@ prop_unfetchedPoolMetadataRefs DBLayer{..} entries = where setup = do run . atomically $ cleanDB - let entries' = (zip [SlotId ep 0 | ep <- [0..]] entries) + let entries' = + [ CertificatePublicationTime (SlotId ep 0) minBound + | ep <- [0 ..] + ] + `zip` entries run . atomically $ mapM_ (uncurry putPoolRegistration) entries' monitor $ classify (length entries > 10) "10+ entries" monitor $ classify (length entries > 50) "50+ entries" @@ -514,7 +866,11 @@ prop_unfetchedPoolMetadataRefsIgnoring DBLayer{..} entries = setup = do run . atomically $ cleanDB - let entries' = (zip [SlotId ep 0 | ep <- [0..]] entries) + let entries' = + [ CertificatePublicationTime (SlotId ep 0) minBound + | ep <- [0 ..] + ] + `zip` entries run . atomically $ mapM_ (uncurry putPoolRegistration) entries' propIgnoredMetadataRefs = do @@ -543,6 +899,88 @@ prop_readSystemSeedIdempotent DBLayer{..} (Positive n) = monitor $ counterexample $ show $ filter (/= firstS) seeds assert (all (== firstS) seeds) +prop_determinePoolRegistrationStatus_orderCorrect + :: forall certificatePublicationTime . (certificatePublicationTime ~ Int) + => (certificatePublicationTime, PoolRegistrationCertificate) + -> (certificatePublicationTime, PoolRetirementCertificate) + -> Property +prop_determinePoolRegistrationStatus_orderCorrect regData retData = + checkCoverage + $ cover 10 (regTime > retTime) + "registration cert time > retirement cert time" + $ cover 10 (regTime < retTime) + "registration cert time < retirement cert time" + $ cover 2 (regTime == retTime) + "registration cert time = retirement cert time" + $ property prop + where + prop + | regTime > retTime = + -- A re-registration always /supercedes/ a prior retirement. + result `shouldBe` PoolRegistered regCert + | regTime < retTime = + -- A retirement always /augments/ the latest registration. + result `shouldBe` PoolRegisteredAndRetired regCert retCert + | otherwise = + -- If a registration certificate and a retirement certificate + -- for the same pool appear to have been published at exactly + -- the same time, this represents a programming error. + evaluate result `shouldThrow` anyException + + sharedPoolId = view #poolId regCertAnyPool + + (regTime, regCertAnyPool) = regData + (retTime, retCertAnyPool) = retData + + regCert = set #poolId sharedPoolId regCertAnyPool + retCert = set #poolId sharedPoolId retCertAnyPool + + result = determinePoolRegistrationStatus + (pure (regTime, regCert)) + (pure (retTime, retCert)) + +-- If we've never seen a registration certificate for a given pool, we /always/ +-- indicate that the pool was /not registered/, /regardless/ of whether or not +-- we've seen a retirement certificate for that pool. +-- +prop_determinePoolRegistrationStatus_neverRegistered + :: forall certificatePublicationTime . (certificatePublicationTime ~ Int) + => Maybe (certificatePublicationTime, PoolRetirementCertificate) + -> Property +prop_determinePoolRegistrationStatus_neverRegistered maybeRetData = + checkCoverage + $ cover 10 (isJust maybeRetData) + "with retirement data" + $ cover 10 (isNothing maybeRetData) + "without retirement data" + $ property + $ result `shouldBe` PoolNotRegistered + where + result = determinePoolRegistrationStatus Nothing maybeRetData + +-- Calling 'determinePoolRegistrationStatus' with certificates from different +-- pools is a programming error, and should result in an exception. +-- +prop_determinePoolRegistrationStatus_differentPools + :: forall certificatePublicationTime . (certificatePublicationTime ~ Int) + => (certificatePublicationTime, PoolRegistrationCertificate) + -> (certificatePublicationTime, PoolRetirementCertificate) + -> Property +prop_determinePoolRegistrationStatus_differentPools regData retData = + property $ (regPoolId /= retPoolId) ==> prop + where + prop = evaluate result `shouldThrow` anyException + + regPoolId = view #poolId regCert + retPoolId = view #poolId retCert + + (regTime, regCert) = regData + (retTime, retCert) = retData + + result = determinePoolRegistrationStatus + (pure (regTime, regCert)) + (pure (retTime, retCert)) + descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation descSlotsPerPool pools = do let checkIfDesc slots = @@ -556,7 +994,7 @@ noEmptyPools pools = do pools' `shouldBe` pools uniqueEpochs :: [(PoolId, BlockHeader)] -> [EpochNo] -uniqueEpochs = nubOrd . map (epochNumber . slotId . snd) +uniqueEpochs = nubOrd . map (epochNumber . view #slotId . snd) -- | Concatenate stake pool production for all epochs in the test fixture. allPoolProduction :: DBLayer IO -> StakePoolsFixture -> IO [(SlotId, PoolId)] @@ -564,4 +1002,6 @@ allPoolProduction DBLayer{..} (StakePoolsFixture pairs _) = atomically $ rearrange <$> mapM readPoolProduction (uniqueEpochs pairs) where rearrange ms = concat - [ [ (slotId h, p) | h <- hs ] | (p, hs) <- concatMap Map.assocs ms ] + [ [ (view #slotId h, p) | h <- hs ] + | (p, hs) <- concatMap Map.assocs ms + ] diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs index 4affdd59d8c..34efe67c01f 100644 --- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs +++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs @@ -76,6 +76,7 @@ import Cardano.Wallet.Network ) import Cardano.Wallet.Primitive.Types ( BlockHeader (..) + , CertificatePublicationTime (..) , EpochNo (..) , PoolId , PoolOwner (..) @@ -198,8 +199,10 @@ monitorStakePools tr (block0, Quantity k) nl db@DBLayer{..} = do forM_ (poolRegistrations block0) $ \r@PoolRegistrationCertificate{poolId} -> do readPoolRegistration poolId >>= \case - Nothing -> putPoolRegistration sl0 r - Just{} -> pure () + Nothing -> do + let cpt = CertificatePublicationTime sl0 minBound + putPoolRegistration cpt r + Just {} -> pure () readPoolProductionCursor (max 100 (fromIntegral k)) forward @@ -222,7 +225,10 @@ monitorStakePools tr (block0, Quantity k) nl db@DBLayer{..} = do lift $ putStakeDistribution ep (Map.toList dist) forM_ blocks $ \b -> do forM_ (poolRegistrations b) $ \pool -> do - lift $ putPoolRegistration (b ^. #header . #slotId) pool + let cpt = CertificatePublicationTime + (b ^. #header . #slotId) + minBound + lift $ putPoolRegistration cpt pool liftIO $ traceWith tr $ MsgStakePoolRegistration pool withExceptT ErrMonitorStakePoolsPoolAlreadyExists $ putPoolProduction (header b) (producer b) @@ -356,7 +362,7 @@ newStakePoolLayer tr block0H getEpCst db@DBLayer{..} nl metadataDir = StakePoolL epConstants = mkEpCst totalStake mergeRegistration poolId (stake, production, performance) = - fmap mkStakePool <$> readPoolRegistration poolId + fmap (mkStakePool . snd) <$> readPoolRegistration poolId where mkStakePool PoolRegistrationCertificate{poolCost,poolMargin,poolOwners} = ( StakePool diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 9b6230e51bd..8cbbb6ce87a 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -208,7 +208,8 @@ prop_trackRegistrations test = monadicIO $ do race_ (takeMVar done) (monitorStakePools tr (block0, Quantity 10) nl db) let pids = poolId <$> expected - atomically $ L.sort . catMaybes <$> mapM readPoolRegistration pids + atomically $ L.sort . fmap snd . catMaybes <$> + mapM readPoolRegistration pids let numDiscoveryLogs = length (filter isDiscoveryMsg logs) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 6c6651e0453..3691d98897a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -32,7 +32,7 @@ import Cardano.BM.Data.Severity import Cardano.BM.Data.Tracer ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) import Cardano.Pool.DB - ( DBLayer (..), ErrPointAlreadyExists (..) ) + ( DBLayer (..), ErrPointAlreadyExists (..), readPoolRegistrationStatus ) import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Network @@ -46,18 +46,23 @@ import Cardano.Wallet.Network import Cardano.Wallet.Primitive.Types ( ActiveSlotCoefficient (..) , BlockHeader + , CertificatePublicationTime (..) , Coin (..) , GenesisParameters (..) , PoolCertificate (..) , PoolId , PoolRegistrationCertificate (..) + , PoolRegistrationStatus (..) , PoolRetirementCertificate (..) , ProtocolParameters , SlotId , SlotLength (..) + , SlotParameters , StakePoolMetadata , StakePoolMetadataHash , StakePoolMetadataUrl + , epochStartTime + , slotParams ) import Cardano.Wallet.Shelley.Compatibility ( Shelley @@ -159,7 +164,7 @@ newStakePoolLayer gp nl db = StakePoolLayer . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) . map snd . Map.toList - $ combineDbAndLsqData lsqData chainData + $ combineDbAndLsqData (slotParams gp) lsqData chainData -- Note: We shouldn't have to do this conversion. el = getEpochLength gp @@ -171,27 +176,29 @@ newStakePoolLayer gp nl db = StakePoolLayer -- -- --- | Stake Pool data fields that we can fetch from the node over Local State --- Query. -data PoolLsqMetrics = PoolLsqMetrics +-- | Stake pool-related data that has been read from the node using a local +-- state query. +data PoolLsqData = PoolLsqData { nonMyopicMemberRewards :: Quantity "lovelace" Word64 , relativeStake :: Percentage , saturation :: Double } deriving (Eq, Show, Generic) --- | Stake Pool data fields that we read from the DB. -data PoolDBMetrics = PoolDBMetrics - { regCert :: PoolRegistrationCertificate +-- | Stake pool-related data that has been read from the database. +data PoolDbData = PoolDbData + { registrationCert :: PoolRegistrationCertificate + , retirementCert :: Maybe PoolRetirementCertificate , nProducedBlocks :: Quantity "block" Word64 , metadata :: Maybe StakePoolMetadata } -- | Top level combine-function that merges DB and LSQ data. combineDbAndLsqData - :: Map PoolId PoolLsqMetrics - -> Map PoolId PoolDBMetrics + :: SlotParameters + -> Map PoolId PoolLsqData + -> Map PoolId PoolDbData -> Map PoolId Api.ApiStakePool -combineDbAndLsqData = +combineDbAndLsqData sp = Map.merge lsqButNoChain chainButNoLsq bothPresent where lsqButNoChain = traverseMissing $ \k lsq -> pure $ mkApiPool k lsq Nothing @@ -204,12 +211,12 @@ combineDbAndLsqData = mkApiPool :: PoolId - -> PoolLsqMetrics - -> Maybe PoolDBMetrics + -> PoolLsqData + -> Maybe PoolDbData -> Api.ApiStakePool mkApiPool pid - (PoolLsqMetrics prew pstk psat) + (PoolLsqData prew pstk psat) dbData = Api.ApiStakePool { Api.id = (ApiT pid) @@ -220,16 +227,21 @@ combineDbAndLsqData = , Api.producedBlocks = maybe (Quantity 0) (fmap fromIntegral . nProducedBlocks) dbData } - , Api.metadata = dbData >>= metadata >>= (return . ApiT) - , Api.cost = fmap fromIntegral . poolCost . regCert <$> dbData - , Api.pledge = fmap fromIntegral . poolPledge . regCert <$> dbData - , Api.margin = Quantity . poolMargin . regCert <$> dbData - -- TODO: Report the actual retirement status of a pool. - -- For the moment, we always report that a pool will never retire. - -- See https://github.com/input-output-hk/cardano-wallet/milestone/89 - , Api.retirement = Nothing + , Api.metadata = + dbData >>= metadata >>= (return . ApiT) + , Api.cost = + fmap fromIntegral . poolCost . registrationCert <$> dbData + , Api.pledge = + fmap fromIntegral . poolPledge . registrationCert <$> dbData + , Api.margin = + Quantity . poolMargin . registrationCert <$> dbData + , Api.retirement = + toApiEpochInfo . retiredIn <$> (retirementCert =<< dbData) } + toApiEpochInfo ep = + Api.ApiEpochInfo (ApiT ep) (epochStartTime sp ep) + -- | Combines all the LSQ data into a single map. -- -- This is the data we can ask the node for the most recent version of, over the @@ -239,7 +251,7 @@ combineDbAndLsqData = -- would be completely impractical. combineLsqData :: NodePoolLsqData - -> Map PoolId PoolLsqMetrics + -> Map PoolId PoolLsqData combineLsqData NodePoolLsqData{nOpt, rewards, stake} = Map.merge stakeButNoRewards rewardsButNoStake bothPresent stake rewards where @@ -249,7 +261,7 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = -- If we fetch non-myopic member rewards of pools using the wallet -- balance of 0, the resulting map will be empty. So we set the rewards -- to 0 here: - stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqMetrics + stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqData { nonMyopicMemberRewards = Quantity 0 , relativeStake = s , saturation = (sat s) @@ -259,7 +271,7 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = -- should we treat it? -- -- The pool with rewards but not stake didn't seem to be retiring. - rewardsButNoStake = traverseMissing $ \_k r -> pure $ PoolLsqMetrics + rewardsButNoStake = traverseMissing $ \_k r -> pure $ PoolLsqData { nonMyopicMemberRewards = r , relativeStake = noStake , saturation = sat noStake @@ -267,15 +279,17 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = where noStake = unsafeMkPercentage 0 - bothPresent = zipWithMatched $ \_k s r -> PoolLsqMetrics r s (sat s) + bothPresent = zipWithMatched $ \_k s r -> PoolLsqData r s (sat s) -- | Combines all the chain-following data into a single map -- (doesn't include metadata) combineChainData - :: Map PoolId PoolRegistrationCertificate + :: Map PoolId (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) -> Map PoolId (Quantity "block" Word64) -> Map PoolId - (PoolRegistrationCertificate, Quantity "block" Word64) + ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + , Quantity "block" Word64 + ) combineChainData = Map.merge registeredNoProductions notRegisteredButProducing bothPresent where @@ -292,26 +306,42 @@ combineChainData = -- hand-written Sqlite query. readDBPoolData :: DBLayer IO - -> IO (Map PoolId PoolDBMetrics) -readDBPoolData DBLayer{..} = atomically $ do + -> IO (Map PoolId PoolDbData) +readDBPoolData db@DBLayer{..} = atomically $ do pools <- listRegisteredPools - registrations <- mapM readPoolRegistration pools + registrationStatuses <- mapM (liftIO . readPoolRegistrationStatus db) pools let certMap = Map.fromList - [(poolId, cert) | (poolId, Just cert) <- zip pools registrations] + [ (poolId, certs) + | (poolId, Just certs) <- zip pools + (certificatesFromRegistrationStatus <$> registrationStatuses) + ] prodMap <- readTotalProduction metaMap <- readPoolMetadata return $ Map.map (lookupMetaIn metaMap) (combineChainData certMap prodMap) where + certificatesFromRegistrationStatus + :: PoolRegistrationStatus + -> Maybe (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + certificatesFromRegistrationStatus = \case + PoolNotRegistered -> + Nothing + PoolRegistered regCert -> + Just (regCert, Nothing) + PoolRegisteredAndRetired regCert retCert -> + Just (regCert, Just retCert) + lookupMetaIn :: Map StakePoolMetadataHash StakePoolMetadata - -> (PoolRegistrationCertificate, Quantity "block" Word64) - -> PoolDBMetrics - lookupMetaIn m (cert, n) = + -> ( (PoolRegistrationCertificate, Maybe PoolRetirementCertificate) + , Quantity "block" Word64 + ) + -> PoolDbData + lookupMetaIn m ((registrationCert, mRetirementCert), n) = let - metaHash = snd <$> poolMetadata cert + metaHash = snd <$> poolMetadata registrationCert meta = flip Map.lookup m =<< metaHash in - PoolDBMetrics cert n meta + PoolDbData registrationCert mRetirementCert n meta -- -- Monitoring stake pool @@ -353,22 +383,44 @@ monitorStakePools tr gp nl db@DBLayer{..} = do -> IO (FollowAction ()) forward blocks (_nodeTip, _pparams) = do atomically $ forM_ blocks $ \blk -> do - let (slot, registrations) = fromShelleyBlock' getEpochLength blk - runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case - Left e -> liftIO $ traceWith tr $ MsgErrProduction e - Right () -> pure () - forM_ registrations $ \case - Registration pool -> do - liftIO $ traceWith tr $ MsgStakePoolRegistration pool - putPoolRegistration slot pool - Retirement cert -> do + let (slot, certificates) = fromShelleyBlock' getEpochLength blk + runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) + >>= \case + Left e -> + liftIO $ traceWith tr $ MsgErrProduction e + Right () -> + pure () + + -- A single block can contain multiple certificates relating to the + -- same pool. + -- + -- The /order/ in which certificates appear is /significant/: + -- certificates that appear later in a block /generally/ take + -- precedence over certificates that appear earlier on. + -- + -- We record /all/ certificates within the database, together with + -- the order in which they appeared. + -- + -- Precedence is determined by the 'readPoolRegistrationStatus' + -- function. + -- + let publicationTimes = + CertificatePublicationTime slot <$> [minBound ..] + forM_ (publicationTimes `zip` certificates) $ \case + (publicationTime, Registration cert) -> do + liftIO $ traceWith tr $ MsgStakePoolRegistration cert + putPoolRegistration publicationTime cert + (publicationTime, Retirement cert) -> do liftIO $ traceWith tr $ MsgStakePoolRetirement cert + putPoolRetirement publicationTime cert pure Continue monitorMetadata :: Tracer IO StakePoolLog -> GenesisParameters - -> (StakePoolMetadataUrl -> StakePoolMetadataHash -> IO (Either String StakePoolMetadata)) + -> (StakePoolMetadataUrl + -> StakePoolMetadataHash + -> IO (Either String StakePoolMetadata)) -> DBLayer IO -> IO () monitorMetadata tr gp fetchMetadata DBLayer{..} = forever $ do @@ -441,12 +493,14 @@ instance ToText StakePoolLog where ] MsgHaltMonitoring -> "Stopping stake pool monitoring as requested." - MsgCrashMonitoring -> - "Chain follower exited with error. Worker will no longer monitor stake pools." + MsgCrashMonitoring -> mconcat + [ "Chain follower exited with error. " + , "Worker will no longer monitor stake pools." + ] MsgRollingBackTo point -> "Rolling back to " <> pretty point - MsgStakePoolRegistration pool -> - "Discovered stake pool registration: " <> pretty pool + MsgStakePoolRegistration cert -> + "Discovered stake pool registration: " <> pretty cert MsgStakePoolRetirement cert -> "Discovered stake pool retirement: " <> pretty cert MsgErrProduction (ErrPointAlreadyExists blk) -> mconcat @@ -464,6 +518,7 @@ instance ToText StakePoolLog where [ "Failed to fetch metadata from ", toText url, ": ", T.pack msg ] MsgFetchTakeBreak delay -> mconcat - [ "Taking a little break from fetching metadata, back to it in about " + [ "Taking a little break from fetching metadata, " + , "back to it in about " , pretty (fixedF 1 (toRational delay / 1000000)), "s" ]