diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index c4695c8c187..cccb7be0f95 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -89,6 +89,7 @@ library , statistics , stm , streaming-commons + , string-qq , template-haskell , text , text-class diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 6af4687171f..df69acd1e6a 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -171,6 +171,12 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- map we would get from 'readPoolProduction' because not all registered -- pools have necessarily produced any block yet! + , listRetiredPools + :: EpochNo + -> stm [PoolRetirementCertificate] + -- ^ List all pools with an active retirement epoch that is earlier + -- than or equal to the specified epoch. + , putPoolMetadata :: StakePoolMetadataHash -> StakePoolMetadata diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index 7363d32881c..1697bd54fd5 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -25,6 +25,7 @@ import Cardano.Pool.DB.Model , emptyPoolDatabase , mCleanPoolProduction , mListRegisteredPools + , mListRetiredPools , mPutFetchAttempt , mPutPoolMetadata , mPutPoolProduction @@ -115,6 +116,9 @@ newDBLayer timeInterpreter = do , listRegisteredPools = modifyMVar db (pure . swap . mListRegisteredPools) + , listRetiredPools = \epochNo -> + modifyMVar db (pure . swap . mListRetiredPools epochNo) + , putPoolMetadata = \a0 a1 -> void $ alterPoolDB (const Nothing) db (mPutPoolMetadata a0 a1) diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index a0d977dbce5..205f2c0c04a 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -47,6 +47,7 @@ module Cardano.Pool.DB.Model , mPutFetchAttempt , mPutPoolMetadata , mListRegisteredPools + , mListRetiredPools , mReadSystemSeed , mRollbackTo , mReadCursor @@ -54,6 +55,8 @@ module Cardano.Pool.DB.Model import Prelude +import Cardano.Pool.DB + ( determinePoolLifeCycleStatus ) import Cardano.Wallet.Primitive.Slotting ( TimeInterpreter, epochOf ) import Cardano.Wallet.Primitive.Types @@ -61,6 +64,7 @@ import Cardano.Wallet.Primitive.Types , CertificatePublicationTime , EpochNo (..) , PoolId + , PoolLifeCycleStatus (..) , PoolOwner (..) , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) @@ -68,17 +72,22 @@ import Cardano.Wallet.Primitive.Types , StakePoolMetadata , StakePoolMetadataHash , StakePoolMetadataUrl + , getPoolRetirementCertificate ) import Data.Bifunctor ( first ) import Data.Foldable ( fold ) +import Data.Function + ( (&) ) import Data.Functor.Identity ( Identity (..) ) import Data.Generics.Internal.VL.Lens ( view ) import Data.Map.Strict ( Map ) +import Data.Maybe + ( catMaybes ) import Data.Ord ( Down (..) ) import Data.Quantity @@ -260,6 +269,44 @@ mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase) mListRegisteredPools db@PoolDatabase{registrations} = ( snd <$> Map.keys registrations, db ) +mListRetiredPools + :: EpochNo + -> PoolDatabase + -> ([PoolRetirementCertificate], PoolDatabase) +mListRetiredPools epochNo db = (retiredPools, db) + where + allKnownPoolIds :: [PoolId] + allKnownPoolIds = + L.nub $ snd <$> Map.keys registrations + + retiredPools :: [PoolRetirementCertificate] + retiredPools = activeRetirementCertificates + & filter ((<= epochNo) . view #retiredIn) + + activeRetirementCertificates :: [PoolRetirementCertificate] + activeRetirementCertificates = + allKnownPoolIds + & fmap lookupLifeCycleStatus + & fmap getPoolRetirementCertificate + & catMaybes + + lookupLifeCycleStatus :: PoolId -> PoolLifeCycleStatus + lookupLifeCycleStatus poolId = + determinePoolLifeCycleStatus + (lookupLatestCertificate poolId registrations) + (lookupLatestCertificate poolId retirements) + + lookupLatestCertificate + :: PoolId + -> Map (publicationTime, PoolId) certificate + -> Maybe (publicationTime, certificate) + lookupLatestCertificate poolId certMap = + fmap (first fst) + $ Map.lookupMax + $ Map.filterWithKey (\(_, k) _ -> k == poolId) certMap + + PoolDatabase {registrations, retirements} = db + mUnfetchedPoolMetadataRefs :: Int -> ModelPoolOp [(PoolId, StakePoolMetadataUrl, StakePoolMetadataHash)] diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 9be211db324..00bdd4c2b96 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -25,6 +26,7 @@ module Cardano.Pool.DB.Sqlite ( newDBLayer , withDBLayer , defaultFilePath + , DatabaseView (..) ) where import Prelude @@ -81,6 +83,10 @@ import Data.Quantity ( Percentage (..), Quantity (..) ) import Data.Ratio ( denominator, numerator, (%) ) +import Data.String.QQ + ( s ) +import Data.Text + ( Text ) import Data.Time.Clock ( UTCTime, addUTCTime, getCurrentTime ) import Data.Word @@ -116,6 +122,8 @@ import Cardano.Pool.DB.Sqlite.TH import qualified Data.Map.Strict as Map import qualified Data.Text as T +import qualified Data.Text.Class as T +import qualified Database.Sqlite as Sqlite -- | Return the preferred @FilePath@ for the stake pool .sqlite file, given a -- parent directory. @@ -166,7 +174,7 @@ newDBLayer -> IO (SqliteContext, DBLayer IO) newDBLayer trace fp timeInterpreter = do let io = startSqliteBackend - (ManualMigration mempty) + (migrateManually trace) migrateAll trace fp @@ -347,6 +355,20 @@ newDBLayer trace fp timeInterpreter = do , Desc PoolRegistrationSlotInternalIndex ] + , listRetiredPools = \epochNo -> do + let query = T.unwords + [ "SELECT * FROM " + , databaseViewName activePoolRetirements + , "WHERE retirement_epoch <=" + , T.toText epochNo + , ";" + ] + let safeCast (Single poolId, Single retirementEpoch) = + PoolRetirementCertificate + <$> fromPersistValue poolId + <*> fromPersistValue retirementEpoch + rights . fmap safeCast <$> rawSql query [] + , rollbackTo = \point -> do -- TODO(ADP-356): What if the conversion blocks or fails? -- @@ -446,6 +468,74 @@ newDBLayer trace fp timeInterpreter = do let cpt = CertificatePublicationTime {slotNo, slotInternalIndex} pure (cpt, cert) +migrateManually + :: Tracer IO DBLog + -> ManualMigration +migrateManually _tr = + ManualMigration $ \conn -> + createView conn activePoolRetirements + +-- | Represents a database view. +-- +data DatabaseView = DatabaseView + { databaseViewName :: Text + -- ^ A name for the view. + , databaseViewDefinition :: Text + -- ^ A select query to generate the view. + } + +-- | Creates the specified database view, if it does not already exist. +-- +createView :: Sqlite.Connection -> DatabaseView -> IO () +createView conn (DatabaseView name definition) = do + query <- Sqlite.prepare conn queryString + Sqlite.step query *> Sqlite.finalize query + where + queryString = T.unlines + [ "CREATE VIEW IF NOT EXISTS" + , name + , "AS" + , definition + ] + +-- | Views the set of pool retirements that are currently active. +-- +-- This view includes all pools for which there are published retirement +-- certificates that have not been revoked or superseded. +-- +-- This view does NOT include: +-- +-- - pools for which there are no published retirement certificates. +-- +-- - pools that have had their most-recently-published retirement +-- certificates revoked by subsequent re-registration certificates. +-- +activePoolRetirements :: DatabaseView +activePoolRetirements = DatabaseView "active_pool_retirements" [s| + SELECT * FROM ( + SELECT + pool_id, + retirement_epoch + FROM ( + SELECT row_number() OVER w AS r, * + FROM ( + SELECT + pool_id, slot, slot_internal_index, + NULL as retirement_epoch + FROM pool_registration + UNION + SELECT + pool_id, slot, slot_internal_index, + epoch as retirement_epoch + FROM pool_retirement + ) + WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc) + ) + GROUP BY pool_id + ) + WHERE retirement_epoch IS NOT NULL; +|] + -- | 'Temporary', catches migration error from previous versions and if any, -- _removes_ the database file completely before retrying to start the database. -- diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index cd2d7ac4f87..d9b43678d9e 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -66,6 +66,8 @@ module Cardano.Wallet.Primitive.Types , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , PoolCertificate (..) + , getPoolCertificatePoolId + , setPoolCertificatePoolId , getPoolRegistrationCertificate , getPoolRetirementCertificate @@ -197,7 +199,7 @@ import Data.ByteArray.Encoding import Data.ByteString ( ByteString ) import Data.Generics.Internal.VL.Lens - ( (^.) ) + ( set, view, (^.) ) import Data.Generics.Labels () import Data.Int @@ -1623,6 +1625,20 @@ data PoolCertificate instance NFData PoolCertificate +getPoolCertificatePoolId :: PoolCertificate -> PoolId +getPoolCertificatePoolId = \case + Registration cert -> + view #poolId cert + Retirement cert -> + view #poolId cert + +setPoolCertificatePoolId :: PoolId -> PoolCertificate -> PoolCertificate +setPoolCertificatePoolId newPoolId = \case + Registration cert -> Registration + $ set #poolId newPoolId cert + Retirement cert -> Retirement + $ set #poolId newPoolId cert + -- | Pool ownership data from the stake pool registration certificate. data PoolRegistrationCertificate = PoolRegistrationCertificate { poolId :: !PoolId diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index e4bb1c0b840..0141e1249bc 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -2,13 +2,18 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Pool.DB.Arbitrary - ( StakePoolsFixture (..) + ( ListSerializationMethod + , SinglePoolCertificateSequence (..) + , StakePoolsFixture (..) , genStakePoolMetadata + , isValidSinglePoolCertificateSequence + , serializeLists ) where import Prelude @@ -34,11 +39,15 @@ import Cardano.Wallet.Primitive.Types , StakePoolMetadataHash (..) , StakePoolMetadataUrl (..) , StakePoolTicker (..) + , getPoolCertificatePoolId + , setPoolCertificatePoolId ) import Control.Arrow ( second ) import Control.Monad ( foldM ) +import Data.Function + ( (&) ) import Data.Generics.Internal.VL.Lens ( (^.) ) import Data.Ord @@ -55,9 +64,11 @@ import Test.QuickCheck ( Arbitrary (..) , Gen , PrintableString (..) + , arbitraryBoundedEnum , arbitrarySizedBoundedIntegral , choose , elements + , frequency , genericShrink , listOf , oneof @@ -169,6 +180,81 @@ instance Arbitrary PoolCertificate where ] shrink = const [] +-- | Represents a valid sequence of registration and retirement certificates +-- for a single pool. +-- +data SinglePoolCertificateSequence = SinglePoolCertificateSequence + { getSinglePoolId :: PoolId + , getSinglePoolCertificateSequence :: [PoolCertificate] + } + deriving (Eq, Show) + +isValidSinglePoolCertificateSequence :: SinglePoolCertificateSequence -> Bool +isValidSinglePoolCertificateSequence + (SinglePoolCertificateSequence sharedPoolId certificates) = + allCertificatesReferToSamePool && + firstCertificateIsRegistration + where + allCertificatesReferToSamePool = + all (== sharedPoolId) (getPoolCertificatePoolId <$> certificates) + firstCertificateIsRegistration = case certificates of + Registration _ : _ -> True + Retirement _ : _ -> False + [] -> True + +instance Arbitrary SinglePoolCertificateSequence where + + arbitrary = do + sharedPoolId <- arbitrary + frequency + [ (1, genEmptySequence sharedPoolId) + , (9, genNonEmptySequence sharedPoolId) + ] + where + genEmptySequence sharedPoolId = + pure $ SinglePoolCertificateSequence sharedPoolId [] + genNonEmptySequence sharedPoolId = do + -- We must start with a registration certificate: + certificates <- (:) + <$> (Registration <$> arbitrary) + <*> arbitrary + pure $ SinglePoolCertificateSequence sharedPoolId $ + setPoolCertificatePoolId sharedPoolId <$> certificates + + shrink (SinglePoolCertificateSequence sharedPoolId certificates) = + genericShrink certificates + & fmap (fmap (setPoolCertificatePoolId sharedPoolId)) + & fmap (SinglePoolCertificateSequence sharedPoolId) + & filter isValidSinglePoolCertificateSequence + +-- | Indicates a way to serialize a list of lists into a single list. +-- +data ListSerializationMethod + = Interleave + | Concatenate + deriving (Bounded, Enum, Eq, Show) + +-- | Serializes a list of lists into a single list using the given +-- serialization method. +serializeLists :: ListSerializationMethod -> [[a]] -> [a] +serializeLists = \case + Interleave -> interleave + Concatenate -> concat + +-- Interleaves the given list of lists together in a fair way. +-- +-- Example: +-- +-- >>> interleave [["a1", "a2", "a3"], ["b1", "b2", "b3"], ["c1", "c2", "c3"]] +-- ["a1", "b1", "c1", "a2", "b2", "c3", "a3", "b3", "c3"] +-- +interleave :: [[a]] -> [a] +interleave = concat . L.transpose + +instance Arbitrary ListSerializationMethod where + arbitrary = arbitraryBoundedEnum + 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 7d7460eaceb..4f3522d4a4a 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -27,7 +27,13 @@ import Cardano.Pool.DB , readPoolLifeCycleStatus ) import Cardano.Pool.DB.Arbitrary - ( StakePoolsFixture (..), genStakePoolMetadata ) + ( ListSerializationMethod + , SinglePoolCertificateSequence (..) + , StakePoolsFixture (..) + , genStakePoolMetadata + , isValidSinglePoolCertificateSequence + , serializeLists + ) import Cardano.Pool.DB.Sqlite ( newDBLayer ) import Cardano.Wallet.DummyTarget.Primitive.Types @@ -37,13 +43,14 @@ import Cardano.Wallet.Primitive.Slotting import Cardano.Wallet.Primitive.Types ( BlockHeader (..) , CertificatePublicationTime (..) - , EpochNo + , EpochNo (..) , PoolCertificate (..) , PoolId , PoolLifeCycleStatus (..) , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , SlotNo (..) + , getPoolRetirementCertificate ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) @@ -102,6 +109,7 @@ import Test.QuickCheck , counterexample , cover , property + , shrink , withMaxSuccess , (==>) ) @@ -174,7 +182,7 @@ properties = do it "prop_multiple_putPoolRetirement_single_readPoolRetirement" (property . prop_multiple_putPoolRetirement_single_readPoolRetirement) - it "readPoolLifeCycleStatus should respect registration order" + it "readPoolLifeCycleStatus respects certificate publication order" (property . prop_readPoolLifeCycleStatus) it "rollback of PoolRegistration" (property . prop_rollbackRegistration) @@ -186,6 +194,8 @@ properties = do (property . prop_readSystemSeedIdempotent) it "putPoolRegistration . listRegisteredPools yield pools" (property . prop_listRegisteredPools) + it "prop_listRetiredPools_multiplePools_multipleCerts" + (property . prop_listRetiredPools_multiplePools_multipleCerts) it "putPoolProduction* . readTotalProduction matches expectations" (property . prop_readTotalProduction) it "unfetchedPoolMetadataRefs" @@ -201,6 +211,8 @@ properties = do it "prop_determinePoolLifeCycleStatus_differentPools" (property . const prop_determinePoolLifeCycleStatus_differentPools) + it "SinglePoolCertificateSequence coverage is adequate" + (property . const prop_SinglePoolCertificateSequence_coverage) {------------------------------------------------------------------------------- Properties @@ -465,13 +477,20 @@ prop_poolRegistration DBLayer {..} entries = mapM_ (uncurry putPoolRegistration) entriesIn entriesOut <- run . atomically $ L.sort . catMaybes <$> mapM (readPoolRegistration . view #poolId . snd) entries + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "Written into DB: " , show entriesIn , "Read from DB: " , show entriesOut + , "All pools that are marked to retire: " + , unlines (("\n" <>) . show <$> poolsMarkedToRetire) ] - assert (entriesIn == entriesOut) + assertWith "entriesIn == entriesOut" + $ entriesIn == entriesOut + assertWith "no pools are marked to retire" + $ null poolsMarkedToRetire -- | Heavily relies upon the fact that generated values of 'PoolId' are unique. prop_poolRetirement @@ -488,13 +507,22 @@ prop_poolRetirement DBLayer {..} entries = mapM_ (uncurry putPoolRetirement) entriesIn entriesOut <- run . atomically $ L.sort . catMaybes <$> mapM (readPoolRetirement . view #poolId . snd) entries + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "Written into DB: " , show entriesIn , "Read from DB: " , show entriesOut + , "All pools that are marked to retire: " + , unlines (("\n" <>) . show <$> poolsMarkedToRetire) ] - assert (entriesIn == entriesOut) + assertWith "entriesIn == entriesOut" + $ entriesIn == entriesOut + assertWith "all pools are marked to retire" + $ (==) + (Set.fromList $ snd <$> entriesIn) + (Set.fromList poolsMarkedToRetire) -- For the same pool, write /multiple/ pool registration certificates to the -- database and then read back the current registration certificate, verifying @@ -516,6 +544,8 @@ prop_multiple_putPoolRegistration_single_readPoolRegistration mapM_ (uncurry putPoolRegistration) certificatePublications mRetrievedCertificatePublication <- run $ atomically $ readPoolRegistration sharedPoolId + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "\nExpected certificate publication: " , show mExpectedCertificatePublication @@ -526,9 +556,11 @@ prop_multiple_putPoolRegistration_single_readPoolRegistration , "\nAll certificate publications: " , unlines (("\n" <>) . show <$> certificatePublications) ] - assert $ (==) + assertWith "retrieved certificate matches expectations" $ (==) mRetrievedCertificatePublication mExpectedCertificatePublication + assertWith "pool is not marked to retire" $ + null poolsMarkedToRetire certificatePublications :: [(CertificatePublicationTime, PoolRegistrationCertificate)] @@ -566,6 +598,8 @@ prop_multiple_putPoolRetirement_single_readPoolRetirement mapM_ (uncurry putPoolRetirement) certificatePublications mRetrievedCertificatePublication <- run $ atomically $ readPoolRetirement sharedPoolId + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "\nExpected certificate publication: " , show mExpectedCertificatePublication @@ -576,9 +610,15 @@ prop_multiple_putPoolRetirement_single_readPoolRetirement , "\nAll certificate publications: " , unlines (("\n" <>) . show <$> certificatePublications) ] - assert $ (==) + assertWith "retrieved certificate matches expectations" $ (==) mRetrievedCertificatePublication mExpectedCertificatePublication + assertWith "pool is marked to retire at the correct epoch" $ + case mRetrievedCertificatePublication of + Nothing -> + null poolsMarkedToRetire + Just (_publicationTime, retirementCert) -> + poolsMarkedToRetire == [retirementCert] certificatePublications :: [(CertificatePublicationTime, PoolRetirementCertificate)] @@ -607,24 +647,20 @@ prop_multiple_putPoolRetirement_single_readPoolRetirement -- prop_readPoolLifeCycleStatus :: DBLayer IO - -> PoolId - -> [PoolCertificate] + -> SinglePoolCertificateSequence -> Property prop_readPoolLifeCycleStatus - DBLayer {..} sharedPoolId certificatesManyPoolIds = + DBLayer {..} (SinglePoolCertificateSequence sharedPoolId certificates) = monadicIO (setup >> prop) where setup = run $ atomically cleanDB - expectedStatus = determinePoolLifeCycleStatus - mFinalRegistration - mFinalRetirement - prop = do - actualStatus <- - run $ atomically $ do - mapM_ (uncurry putCertificate) certificatePublications - readPoolLifeCycleStatus sharedPoolId + actualStatus <- run $ atomically $ do + mapM_ (uncurry putCertificate) certificatePublications + readPoolLifeCycleStatus sharedPoolId + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "\nFinal registration: " , show mFinalRegistration @@ -638,52 +674,56 @@ prop_readPoolLifeCycleStatus , show (length certificatePublications) , "\nAll certificate publications: " , unlines (("\n" <>) . show <$> certificatePublications) + , "\nAll pools that are marked to retire: " + , unlines (("\n" <>) . show <$> poolsMarkedToRetire) ] - assert (actualStatus == expectedStatus) + assertWith "actualStatus == expectedStatus" + (actualStatus == expectedStatus) + assertWith "pool is marked to retire only when appropriate" $ + case actualStatus of + PoolNotRegistered -> + null poolsMarkedToRetire + PoolRegistered _regCert -> + null poolsMarkedToRetire + PoolRegisteredAndRetired _regCert retCert -> + poolsMarkedToRetire == [retCert] - certificatePublications :: [(CertificatePublicationTime, PoolCertificate)] - certificatePublications = publicationTimes `zip` certificates + expectedStatus = determinePoolLifeCycleStatus + mFinalRegistration + mFinalRetirement - mFinalRegistration = certificatePublications - & reverse - & fmap (traverse toRegistrationCertificate) - & catMaybes - & listToMaybe + mFinalRegistration = lookupFinalCertificateMatching $ \case + Registration c -> Just c + _ -> Nothing - mFinalRetirement = certificatePublications + mFinalRetirement = lookupFinalCertificateMatching $ \case + Retirement c -> Just c + _ -> Nothing + + lookupFinalCertificateMatching + :: (PoolCertificate -> Maybe certificate) + -> Maybe (CertificatePublicationTime, certificate) + lookupFinalCertificateMatching match = certificatePublications & reverse - & fmap (traverse toRetirementCertificate) + & fmap (traverse match) & catMaybes & listToMaybe + certificatePublications :: [(CertificatePublicationTime, PoolCertificate)] + certificatePublications = publicationTimes `zip` certificates + publicationTimes = [ CertificatePublicationTime (SlotNo sn) ii | 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 -> SlotNo @@ -749,6 +789,8 @@ prop_rollbackRetirement DBLayer{..} certificates = run $ atomically $ rollbackTo rollbackPoint retrievedPublications <- catMaybes <$> run (atomically $ mapM readPoolRetirement poolIds) + poolsMarkedToRetire <- + run $ atomically $ listRetiredPools $ EpochNo maxBound monitor $ counterexample $ unlines [ "\nRollback point: " , show rollbackPoint @@ -758,10 +800,17 @@ prop_rollbackRetirement DBLayer{..} certificates = , unlines (("\n" <>) . show <$> expectedPublications) , "\nRetrieved certificate publications: " , unlines (("\n" <>) . show <$> retrievedPublications) + , "All pools that are marked to retire: " + , unlines (("\n" <>) . show <$> poolsMarkedToRetire) ] - assert $ (==) - retrievedPublications - expectedPublications + assertWith "retrieved publications match expectations" $ + (==) + retrievedPublications + expectedPublications + assertWith "only the correct retirements are listed" $ + (==) + (Set.fromList $ snd <$> expectedPublications) + (Set.fromList poolsMarkedToRetire) poolIds :: [PoolId] poolIds = view #poolId <$> certificates @@ -822,6 +871,91 @@ prop_listRegisteredPools DBLayer {..} entries = ] assert (pools == (view #poolId <$> reverse entries)) +-- | Test that `listRetiredPools` returns the correct set of retirements for +-- any given epoch. +-- +-- This property tests `listRetiredPools` in conditions where: +-- +-- - there are multiple pools; +-- - there are multiple registrations and retirements for each pool; +-- - certificates affecting different pools are interleaved in time. +-- +prop_listRetiredPools_multiplePools_multipleCerts + :: DBLayer IO + -> [SinglePoolCertificateSequence] + -> ListSerializationMethod + -> Property +prop_listRetiredPools_multiplePools_multipleCerts + DBLayer {..} certificateSequences serializationMethod = checkCoverage + -- Check the number of certificates: + $ cover 2 (certificateCount == 0) + "number of certificates: = 0" + $ cover 2 (certificateCount > 0 && certificateCount <= 10) + "number of certificates: > 0 && <= 10" + $ cover 2 (certificateCount > 10 && certificateCount <= 100) + "number of certificates: > 10 && <= 100" + $ cover 2 (certificateCount > 100 && certificateCount <= 1000) + "number of certificates: > 100 && <= 1000" + -- Check the number of pools: + $ cover 2 (poolCount == 0) + "number of pools: = 0" + $ cover 2 (poolCount > 0 && poolCount <= 10) + "number of pools: > 0 && <= 10" + $ cover 2 (poolCount > 10 && poolCount <= 100) + "number of pools: > 10 && <= 100" + $ monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + + prop = do + run $ atomically $ do + mapM_ (uncurry putCertificate) allPublicationsSerialized + lifeCycleStatuses <- run $ atomically $ do + mapM readPoolLifeCycleStatus allPoolIds + let poolsMarkedToRetire = catMaybes $ + getPoolRetirementCertificate <$> lifeCycleStatuses + let epochsToTest = + EpochNo minBound : + EpochNo maxBound : + L.nub (view #retiredIn <$> poolsMarkedToRetire) + forM_ epochsToTest $ \currentEpoch -> do + let retiredPoolsExpected = filter + ((<= currentEpoch) . view #retiredIn) + (poolsMarkedToRetire) + retiredPoolsActual <- + run $ atomically $ listRetiredPools currentEpoch + assert $ (==) + (Set.fromList retiredPoolsActual) + (Set.fromList retiredPoolsExpected) + + certificateCount = length allCertificatesSerialized + poolCount = length certificateSequences + + allCertificatesSerialized :: [PoolCertificate] + allCertificatesSerialized = serializeLists serializationMethod + (getSinglePoolCertificateSequence <$> certificateSequences) + + allPublicationsSerialized + :: [(CertificatePublicationTime, PoolCertificate)] + allPublicationsSerialized = + publicationTimes `zip` allCertificatesSerialized + + allPoolIds :: [PoolId] + allPoolIds = getSinglePoolId <$> certificateSequences + + publicationTimes :: [CertificatePublicationTime] + publicationTimes = + [ CertificatePublicationTime (SlotNo sn) ii + | sn <- [0 .. 3] + , ii <- [0 .. 3] + ] + + putCertificate cpt = \case + Registration cert -> + putPoolRegistration cpt cert + Retirement cert -> + putPoolRetirement cpt cert + prop_unfetchedPoolMetadataRefs :: DBLayer IO -> [PoolRegistrationCertificate] @@ -992,6 +1126,51 @@ prop_determinePoolLifeCycleStatus_differentPools regData retData = (pure (regTime, regCert)) (pure (retTime, retCert)) +prop_SinglePoolCertificateSequence_coverage + :: SinglePoolCertificateSequence + -> Property +prop_SinglePoolCertificateSequence_coverage + s@(SinglePoolCertificateSequence _sharedPoolId certificates) = + checkCoverage + $ cover 2 (null certificates) + "length (all certificates) = 0" + $ cover 2 (length certificates == 1) + "length (all certificates) = 1" + $ cover 2 (length certificates > 1) + "length (all certificates) > 1" + + $ cover 2 (null registrationCertificates) + "length (registration certificates) = 0" + $ cover 2 (length registrationCertificates == 1) + "length (registration certificates) = 1" + $ cover 2 (length registrationCertificates > 1) + "length (registration certificates) > 1" + + $ cover 2 (null retirementCertificates) + "length (retirement certificates) = 0" + $ cover 2 (length retirementCertificates == 1) + "length (retirement certificates) = 1" + $ cover 2 (length retirementCertificates > 1) + "length (retirement certificates) > 1" + + $ cover 50 (not (null shrunkenSequences)) + "length (shrunken sequences) > 0" + + $ all isValidSinglePoolCertificateSequence $ s : shrunkenSequences + where + shrunkenSequences = shrink s + + registrationCertificates = catMaybes + (getRegistrationCertificate <$> certificates) + retirementCertificates = catMaybes + (getRetirementCertificate <$> certificates) + getRegistrationCertificate = \case + Registration cert -> Just cert + Retirement _ -> Nothing + getRetirementCertificate = \case + Registration _ -> Nothing + Retirement cert -> Just cert + descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation descSlotsPerPool pools = do let checkIfDesc slots = diff --git a/nix/.stack.nix/cardano-wallet-core.nix b/nix/.stack.nix/cardano-wallet-core.nix index 6695f430b1a..6de20d30cc1 100644 --- a/nix/.stack.nix/cardano-wallet-core.nix +++ b/nix/.stack.nix/cardano-wallet-core.nix @@ -85,6 +85,7 @@ (hsPkgs."statistics" or (errorHandler.buildDepError "statistics")) (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."streaming-commons" or (errorHandler.buildDepError "streaming-commons")) + (hsPkgs."string-qq" or (errorHandler.buildDepError "string-qq")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."text" or (errorHandler.buildDepError "text")) (hsPkgs."text-class" or (errorHandler.buildDepError "text-class"))