Merge #1945

1945: Exclude retired pools from the `ListStakePools` API function result. r=jonathanknowles a=jonathanknowles

# Issue Number

#1937 

# Overview

This PR:

- [x] Applies a very simple filter to the Shelley `ListStakePools` API operation that excludes all pools with a retirement epoch earlier than or equal to the current epoch.
- [x]  Adds an integration test to verify that if pool _**p**_ has already retired, it will **not** be listed by `ListStakePools`.

# Future Improvements

The current pool tracking implementation (which predates this PR) has two potential areas for improvement:

- Reducing the number of database queries that need to be executed:
    See: https://jira.iohk.io/browse/ADP-383
- Performing garbage collection of retired pools from the database:
    See: https://jira.iohk.io/browse/ADP-376

These are **not** tackled in this PR, but are instead recorded in the above tickets, so that we may schedule time to fix them at a later date.

Co-authored-by: Jonathan Knowles <[email protected]>

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -660,7 +660,7 @@ spec = do
         it "contains pool metadata" $ \ctx -> do
             eventually "metadata is fetched" $ do
                 r <- listPools ctx arbitraryStake
-                let metadataList =
+                let metadataPossible = Set.fromList
                         [ StakePoolMetadata
                             { ticker = (StakePoolTicker "GPA")
                             , name = "Genesis Pool A"
@@ -679,16 +679,21 @@ spec = do
                             , description = Just "Lorem Ipsum Dolor Sit Amet."
                             , homepage = "https://iohk.io"
                             }
+                        , StakePoolMetadata
+                            { ticker = (StakePoolTicker "GPD")
+                            , name = "Genesis Pool D"
+                            , description = Just "Lorem Ipsum Dolor Sit Amet."
+                            , homepage = "https://iohk.io"
+                            }
                         ]
 
                 verify r
                     [ expectListSize 3
-                    , expectField Prelude.id $ \pools ->
-                        -- To ignore the arbitrary order,
-                        -- we sort on the names before comparing
-                        sortOn name
-                            (mapMaybe (fmap getApiT . view #metadata) pools)
-                            `shouldBe` metadataList
+                    , expectField Prelude.id $ \pools -> do
+                        let metadataActual = Set.fromList $
+                                mapMaybe (fmap getApiT . view #metadata) pools
+                        metadataActual
+                            `shouldSatisfy` (`Set.isSubsetOf` metadataPossible)
                     ]
 
         it "contains and is sorted by non-myopic-rewards" $ \ctx -> do

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -616,7 +616,7 @@ data StakePoolMetadata = StakePoolMetadata
     -- ^ Short description of the stake pool.
     , homepage :: Text
     -- ^ Absolute URL for the stake pool's homepage link.
-    } deriving (Eq, Show, Generic)
+    } deriving (Eq, Ord, Show, Generic)
 
 instance FromJSON StakePoolMetadata where
     parseJSON = withObject "StakePoolMetadta" $ \obj -> do
@@ -635,7 +635,7 @@ instance FromJSON StakePoolMetadata where
 
 -- | Very short name for a stake pool.
 newtype StakePoolTicker = StakePoolTicker { unStakePoolTicker :: Text }
-    deriving stock (Generic, Show, Eq)
+    deriving stock (Generic, Show, Eq, Ord)
     deriving newtype (ToText)
 
 instance FromText StakePoolTicker where

lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs

@@ -48,6 +48,7 @@ import Cardano.Wallet.Api.Server
     , delegationFee
     , deleteTransaction
     , deleteWallet
+    , getCurrentEpoch
     , getMigrationInfo
     , getNetworkClock
     , getNetworkInformation
@@ -184,19 +185,21 @@ server byron icarus shelley spl ntp =
 
     stakePools :: Server (StakePools n ApiStakePool)
     stakePools =
-        (\case
-            Just (ApiT stake) -> liftHandler $ listStakePools spl stake
+        listStakePools_
+        :<|> joinStakePool shelley (knownPools spl) (getPoolLifeCycleStatus spl)
+        :<|> quitStakePool shelley
+        :<|> delegationFee shelley
+      where
+        listStakePools_ = \case
+            Just (ApiT stake) -> do
+                currentEpoch <- getCurrentEpoch shelley
+                liftHandler $ listStakePools spl currentEpoch stake
             Nothing -> Handler $ throwE $ apiError err400 QueryParamMissing $
                 mconcat
                 [ "The stake intended to delegate must be provided as a query "
                 , "parameter as it affects the rewards and ranking."
                 ]
 
-        )
-        :<|> joinStakePool shelley (knownPools spl) (getPoolLifeCycleStatus spl)
-        :<|> quitStakePool shelley
-        :<|> delegationFee shelley
-
     byronWallets :: Server ByronWallets
     byronWallets =
         (\case

lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs

@@ -1122,6 +1122,33 @@ operators = unsafePerformIO $ newMVar
           , "homepage" .= Aeson.String "https://iohk.io"
           ]
       )
+    , ( PoolId $ unsafeFromHex
+          "5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec36"
+      , Aeson.object
+          [ "type" .= Aeson.String "Node operator verification key"
+          , "description" .= Aeson.String "Stake Pool Operator Verification Key"
+          , "cborHex" .= Aeson.String
+              "58203263e07605b9fc0100eb520d317f472ae12989fbf27fc71f46310bc0f24f2970"
+          ]
+      , Aeson.object
+          [ "type" .= Aeson.String "Node operator signing key"
+          , "description" .= Aeson.String "Stake Pool Operator Signing Key"
+          , "cborHex" .= Aeson.String
+              "58208f50de27d74325eaf57767d70277210b31eb97cdc3033f632a9791a3677a64d2"
+          ]
+      , Aeson.object
+          [ "type" .= Aeson.String "Node operational certificate issue counter"
+          , "description" .= Aeson.String "Next certificate issue number: 0"
+          , "cborHex" .= Aeson.String
+              "820058203263e07605b9fc0100eb520d317f472ae12989fbf27fc71f46310bc0f24f2970"
+          ]
+      , Aeson.object
+          [ "name" .= Aeson.String "Genesis Pool D"
+          , "ticker" .= Aeson.String "GPD"
+          , "description" .= Aeson.String "Lorem Ipsum Dolor Sit Amet."
+          , "homepage" .= Aeson.String "https://iohk.io"
+          ]
+      )
     ]
 {-# NOINLINE operators #-}
 

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -51,6 +51,7 @@ import Cardano.Wallet.Primitive.Types
     , BlockHeader
     , CertificatePublicationTime (..)
     , Coin (..)
+    , EpochNo (..)
     , GenesisParameters (..)
     , PoolCertificate (..)
     , PoolId
@@ -88,6 +89,8 @@ import Control.Monad.Trans.Except
     ( ExceptT (..), runExceptT )
 import Control.Tracer
     ( Tracer, contramap, traceWith )
+import Data.Function
+    ( (&) )
 import Data.Generics.Internal.VL.Lens
     ( view )
 import Data.List
@@ -131,10 +134,16 @@ data StakePoolLayer = StakePoolLayer
         :: IO [PoolId]
 
     -- | List pools based given the the amount of stake the user intends to
-    -- delegate, which affects the size of the rewards and the ranking of the
-    -- pools.
+    --   delegate, which affects the size of the rewards and the ranking of
+    --   the pools.
+    --
+    -- Pools with a retirement epoch earlier than or equal to the specified
+    -- epoch will be excluded from the result.
+    --
     , listStakePools
-        :: Coin
+        :: EpochNo
+        -- Exclude all pools that retired in or before this epoch.
+        -> Coin
         -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
     }
 
@@ -166,17 +175,35 @@ newStakePoolLayer gp nl db@DBLayer {..} = StakePoolLayer
             Left _e -> return []
 
     _listPools
-        :: Coin
+        :: EpochNo
+        -- Exclude all pools that retired in or before this epoch.
+        -> Coin
         -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
-    _listPools userStake = do
+    _listPools currentEpoch userStake = do
         tip <- liftIO getTip
         lsqData <- combineLsqData <$> stakeDistribution nl tip userStake
         dbData <- liftIO $ readPoolDbData db
+        -- TODO:
+        -- Use a more efficient way of filtering out retired pools.
+        -- See: https://jira.iohk.io/projects/ADP/issues/ADP-383
         return
             . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards)))
+            . filter (not . poolIsRetired)
             . map snd
             . Map.toList
             $ combineDbAndLsqData (slotParams gp) lsqData dbData
+      where
+        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))
 
     gh = getGenesisBlockHash gp
     getTip = fmap (toPoint gh) . liftIO $ unsafeRunExceptT $ currentNodeTip nl
@@ -325,9 +352,34 @@ combineChainData registrationMap retirementMap prodMap metaMap =
         mRetirementCert =
             Map.lookup (view #poolId registrationCert) retirementMap
 
--- NOTE: If performance becomes a problem, we could try replacing all
--- the individual database queries and combining functions with a single
--- hand-written database query.
+-- 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
+--
+-- Additionally, we can consider performing garbage collection of retired pools
+-- from the database:
+--
+--    See: https://jira.iohk.io/browse/ADP-376
+--
 readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData)
 readPoolDbData DBLayer {..} = atomically $ do
     pools <- listRegisteredPools

lib/shelley/test/integration/Main.hs

@@ -180,8 +180,13 @@ main = withUtf8Encoding $ withTracers $ \tracers -> do
 
 testPoolConfigs :: [PoolConfig]
 testPoolConfigs =
-    [ PoolConfig {retirementEpoch = Nothing}
+    [ -- This pool should never retire:
+      PoolConfig {retirementEpoch = Nothing}
+      -- This pool should retire almost immediately:
+    , PoolConfig {retirementEpoch = Just 1}
+      -- This pool should retire, but not within the duration of a test run:
     , PoolConfig {retirementEpoch = Just 1_000}
+      -- This pool should retire, but not within the duration of a test run:
     , PoolConfig {retirementEpoch = Just 1_000_000}
     ]