diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 15becfd71c7..c191d200d1a 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -177,6 +177,13 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- ^ List all pools with an active retirement epoch that is earlier -- than or equal to the specified epoch. + , listPoolLifeCycleData + :: EpochNo + -> stm [PoolLifeCycleStatus] + -- ^ List the lifecycle data of all non-retired pools: pools that + -- either don't have an active retirement epoch or pools that have + -- an active retirement epoch that is later than the given 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 24621f0c256..3bf9ff089ff 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -65,6 +65,8 @@ import Data.Generics.Internal.VL.Lens import Data.Tuple ( swap ) +import qualified Data.Set as Set + -- | Instantiate a new in-memory "database" layer that simply stores data in -- a local MVar. Data vanishes if the software is shut down. newDBLayer :: TimeInterpreter Identity -> IO (DBLayer IO) @@ -124,6 +126,14 @@ newDBLayer timeInterpreter = do listRetiredPools epochNo = modifyMVar db (pure . swap . mListRetiredPools epochNo) + listPoolLifeCycleData epochNo = do + registeredPools <- Set.fromList + <$> listRegisteredPools + retiredPools <- Set.fromList . fmap (view #poolId) + <$> listRetiredPools epochNo + let nonRetiredPools = registeredPools `Set.difference` retiredPools + mapM readPoolLifeCycleStatus $ Set.toList nonRetiredPools + putPoolMetadata a0 a1 = void $ alterPoolDB (const Nothing) db (mPutPoolMetadata a0 a1) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 0927cb0e462..72db870270f 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -59,6 +59,7 @@ import Cardano.Wallet.Primitive.Types , CertificatePublicationTime (..) , EpochNo (..) , PoolId + , PoolLifeCycleStatus (..) , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) , StakePoolMetadata (..) @@ -80,6 +81,8 @@ import Data.Either ( rights ) import Data.Function ( (&) ) +import Data.Functor + ( (<&>) ) import Data.Generics.Internal.VL.Lens ( view ) import Data.List @@ -208,14 +211,20 @@ newDBLayer trace fp timeInterpreter = do pure (foldl' toMap Map.empty production) - readTotalProduction = do - production <- fmap entityVal <$> - selectList ([] :: [Filter PoolProduction]) [] - - let toMap m (PoolProduction{poolProductionPoolId}) = - Map.insertWith (+) poolProductionPoolId 1 m - - pure $ Map.map Quantity $ foldl' toMap Map.empty production + readTotalProduction = + Map.fromList . rights . fmap parseRow <$> rawSql query [] + where + query = T.unwords + [ "SELECT pool_id, count(pool_id) as block_count" + , "FROM pool_production" + , "GROUP BY pool_id;" + ] + parseRow + ( Single fieldPoolId + , Single fieldBlockCount + ) = (,) + <$> fromPersistValue fieldPoolId + <*> (Quantity <$> fromPersistValue fieldBlockCount) putStakeDistribution epoch@(EpochNo ep) distribution = do deleteWhere [StakeDistributionEpoch ==. fromIntegral ep] @@ -372,6 +381,55 @@ newDBLayer trace fp timeInterpreter = do <*> fromPersistValue retirementEpoch rights . fmap safeCast <$> rawSql query parameters + listPoolLifeCycleData epochNo = + rights . fmap parseRow <$> rawSql query parameters + where + query = T.unwords + [ "SELECT *" + , "FROM active_pool_lifecycle_data" + , "WHERE retirement_epoch IS NULL OR retirement_epoch > ?;" + ] + parameters = [ toPersistValue epochNo ] + parseRow + ( Single fieldPoolId + , Single fieldRetirementEpoch + , Single fieldOwners + , Single fieldCost + , Single fieldPledge + , Single fieldMarginNumerator + , Single fieldMarginDenominator + , Single fieldMetadataHash + , Single fieldMetadataUrl + ) = do + regCert <- parseRegistrationCertificate + parseRetirementCertificate <&> maybe + (PoolRegistered regCert) + (PoolRegisteredAndRetired regCert) + where + parseRegistrationCertificate = PoolRegistrationCertificate + <$> fromPersistValue fieldPoolId + <*> fromPersistValue fieldOwners + <*> parseMargin + <*> (Quantity <$> fromPersistValue fieldCost) + <*> (Quantity <$> fromPersistValue fieldPledge) + <*> parseMetadata + + parseRetirementCertificate = do + poolId <- fromPersistValue fieldPoolId + mRetirementEpoch <- fromPersistValue fieldRetirementEpoch + pure $ PoolRetirementCertificate poolId <$> mRetirementEpoch + + parseMargin = mkMargin + <$> fromPersistValue @Word64 fieldMarginNumerator + <*> fromPersistValue @Word64 fieldMarginDenominator + where + mkMargin n d = unsafeMkPercentage $ toRational $ n % d + + parseMetadata = do + u <- fromPersistValue fieldMetadataUrl + h <- fromPersistValue fieldMetadataHash + pure $ (,) <$> u <*> h + rollbackTo point = do -- TODO(ADP-356): What if the conversion blocks or fails? -- @@ -497,7 +555,10 @@ migrateManually :: Tracer IO PoolDbLog -> ManualMigration migrateManually _tr = - ManualMigration $ \conn -> + ManualMigration $ \conn -> do + createView conn activePoolLifeCycleData + createView conn activePoolOwners + createView conn activePoolRegistrations createView conn activePoolRetirements -- | Represents a database view. @@ -523,6 +584,89 @@ createView conn (DatabaseView name definition) = do , definition ] +-- | Views active life-cycle data for every pool in the set of known pools. +-- +-- This view has exactly ONE row for each known pool, where each row +-- corresponds to the most-recently-seen registration certificate, +-- retirement certificate, and set of owners for that pool. +-- +-- This view does NOT exclude pools that have retired. +-- +activePoolLifeCycleData :: DatabaseView +activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [s| + SELECT + active_pool_registrations.pool_id as pool_id, + active_pool_retirements.retirement_epoch as retirement_epoch, + active_pool_owners.pool_owners as pool_owners, + cost, + pledge, + margin_numerator, + margin_denominator, + metadata_hash, + metadata_url + FROM + active_pool_registrations + LEFT JOIN + active_pool_retirements + ON active_pool_registrations.pool_id = active_pool_retirements.pool_id + LEFT JOIN + active_pool_owners + ON active_pool_registrations.pool_id = active_pool_owners.pool_id; +|] + +-- | Views the set of active owners for all pools. +-- +-- This view has exactly ONE row for each known pool, where each row +-- corresponds to the most-recently-seen set of owners for that pool. +-- +-- This view does NOT exclude pools that have retired. +-- +activePoolOwners :: DatabaseView +activePoolOwners = DatabaseView "active_pool_owners" [s| + SELECT pool_id, pool_owners FROM ( + SELECT row_number() OVER w AS r, * + FROM ( + SELECT + pool_id, + slot, + slot_internal_index, + group_concat(pool_owner, ' ') as pool_owners + FROM ( + SELECT * FROM pool_owner ORDER BY pool_owner_index + ) + GROUP BY pool_id, slot, slot_internal_index + ) + WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc) + ) + GROUP BY pool_id; +|] + +-- | Views the set of pool registrations that are currently active. +-- +-- This view has exactly ONE row for each known pool, where each row +-- corresponds to the most-recently-seen registration certificate for +-- that pool. +-- +-- This view does NOT exclude pools that have retired. +-- +activePoolRegistrations :: DatabaseView +activePoolRegistrations = DatabaseView "active_pool_registrations" [s| + SELECT + pool_id, + cost, + pledge, + margin_numerator, + margin_denominator, + metadata_hash, + metadata_url + FROM ( + SELECT row_number() OVER w AS r, * + FROM pool_registration + WINDOW w AS (ORDER BY pool_id, slot desc, slot_internal_index desc) + ) + GROUP BY pool_id; +|] + -- | Views the set of pool retirements that are currently active. -- -- This view includes all pools for which there are published retirement diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs index a1b91d53da0..2b359c9ce53 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs @@ -461,6 +461,16 @@ instance PersistFieldSql PoolOwner where instance Read PoolOwner where readsPrec _ = error "readsPrec stub needed for persistent" +instance FromText [PoolOwner] where + fromText t = mapM fromText $ T.words t + +instance PersistField [PoolOwner] where + toPersistValue v = toPersistValue $ T.unwords $ toText <$> v + fromPersistValue = fromPersistValueFromText + +instance PersistFieldSql [PoolOwner] where + sqlType _ = sqlType (Proxy @Text) + ---------------------------------------------------------------------------- -- HDPassphrase diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 8ec5f62642d..9af1a7190a7 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -94,6 +94,8 @@ import Control.Monad.Trans.State ( State, evalState, state ) import Control.Tracer ( Tracer, contramap, traceWith ) +import Data.Bifunctor + ( first ) import Data.Function ( (&) ) import Data.Generics.Internal.VL.Lens @@ -116,6 +118,8 @@ import Data.Set ( Set ) import Data.Text.Class ( ToText (..) ) +import Data.Tuple.Extra + ( dupe ) import Data.Word ( Word64 ) import Fmt @@ -180,7 +184,7 @@ newStakePoolLayer nl db@DBLayer {..} = _knownPools :: IO (Set PoolId) _knownPools = - Map.keysSet <$> liftIO (readPoolDbData db) + Map.keysSet <$> liftIO (readPoolDbData db maxBound) _listPools :: EpochNo @@ -191,14 +195,10 @@ newStakePoolLayer nl db@DBLayer {..} = tip <- withExceptT fromErrCurrentNodeTip $ currentNodeTip nl rawLsqData <- stakeDistribution nl tip userStake let lsqData = combineLsqData rawLsqData - dbData <- liftIO $ readPoolDbData db + dbData <- liftIO $ readPoolDbData db currentEpoch seed <- liftIO $ atomically readSystemSeed - -- TODO: - -- Use a more efficient way of filtering out retired pools. - -- See: https://jira.iohk.io/projects/ADP/issues/ADP-383 liftIO $ sortByReward seed - . filter (not . poolIsRetired) . map snd . Map.toList <$> combineDbAndLsqData @@ -212,18 +212,6 @@ newStakePoolLayer nl db@DBLayer {..} = ErrCurrentNodeTipNetworkUnreachable e -> e ErrCurrentNodeTipNotFound -> ErrNetworkUnreachable "tip not found" - epochIsInFuture :: EpochNo -> Bool - epochIsInFuture = (> currentEpoch) - - poolIsRetired :: Api.ApiStakePool -> Bool - poolIsRetired = - maybe False (not . epochIsInFuture) . poolRetirementEpoch - - poolRetirementEpoch :: Api.ApiStakePool -> Maybe EpochNo - poolRetirementEpoch p = p - & view #retirement - & fmap (view (#epochNumber . #getApiT)) - -- Sort by non-myopic member rewards, making sure to also randomly sort -- pools that have equal rewards. -- @@ -427,40 +415,22 @@ combineChainData registrationMap retirementMap prodMap metaMap = mRetirementCert = Map.lookup (view #poolId registrationCert) retirementMap --- TODO: --- --- This function currently executes a total of (2n + 1) database queries, where --- n is the total number of pools with entries in the pool registrations table. --- --- Specifically: --- --- 1. We first execute a query to determine the complete set of all pools --- (including those that may have retired). --- --- 2. For each pool, we determine its current life-cycle status by executing --- a pair of queries to fetch: --- --- a. The most recent registration certificate. --- b. The most recent retirement certificate. --- --- This is almost certainly not optimal. --- --- If performance becomes a problem, we should investigate ways to reduce the --- number of queries required: --- --- See: https://jira.iohk.io/browse/ADP-383 --- -readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData) -readPoolDbData DBLayer {..} = atomically $ do - pools <- listRegisteredPools - lifeCycleStatuses <- mapM readPoolLifeCycleStatus pools - let mkCertificateMap - :: forall a . (PoolLifeCycleStatus -> Maybe a) -> Map PoolId a - mkCertificateMap f = Map.fromList - [(p, c) | (p, Just c) <- zip pools (f <$> lifeCycleStatuses)] +readPoolDbData :: DBLayer IO -> EpochNo -> IO (Map PoolId PoolDbData) +readPoolDbData DBLayer {..} currentEpoch = atomically $ do + lifeCycleData <- listPoolLifeCycleData currentEpoch + let registrationCertificates = lifeCycleData + & fmap getPoolRegistrationCertificate + & catMaybes + & fmap (first (view #poolId) . dupe) + & Map.fromList + let retirementCertificates = lifeCycleData + & fmap getPoolRetirementCertificate + & catMaybes + & fmap (first (view #poolId) . dupe) + & Map.fromList combineChainData - (mkCertificateMap getPoolRegistrationCertificate) - (mkCertificateMap getPoolRetirementCertificate) + registrationCertificates + retirementCertificates <$> readTotalProduction <*> readPoolMetadata