Try #2024:

lib/core/cardano-wallet-core.cabal

@@ -89,6 +89,7 @@ library
     , statistics
     , stm
     , streaming-commons
+    , string-qq
     , template-haskell
     , text
     , text-class

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

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)
 

lib/core/src/Cardano/Pool/DB/Model.hs

@@ -47,38 +47,47 @@ module Cardano.Pool.DB.Model
     , mPutFetchAttempt
     , mPutPoolMetadata
     , mListRegisteredPools
+    , mListRetiredPools
     , mReadSystemSeed
     , mRollbackTo
     , mReadCursor
     ) where
 
 import Prelude
 
+import Cardano.Pool.DB
+    ( determinePoolLifeCycleStatus )
 import Cardano.Wallet.Primitive.Slotting
     ( TimeInterpreter, epochOf )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , CertificatePublicationTime
     , EpochNo (..)
     , PoolId
+    , PoolLifeCycleStatus (..)
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
     , SlotNo (..)
     , 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)]

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.
 --

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