Try #2111:

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

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)
 

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

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
 

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