From a6ee77d5b55be27c72ae2d441cbf4e9dc961f5e5 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Tue, 1 Sep 2020 08:21:21 +0000
Subject: [PATCH 01/23] Add `active_pool_registrations` pool database view.

---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 29 +++++++++++++++++++++++++-
 1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index 0927cb0e462..1748e75f9c2 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -497,7 +497,8 @@ migrateManually
     :: Tracer IO PoolDbLog
     -> ManualMigration
 migrateManually _tr =
-    ManualMigration $ \conn ->
+    ManualMigration $ \conn -> do
+        createView conn activePoolRegistrations
         createView conn activePoolRetirements
 
 -- | Represents a database view.
@@ -523,6 +524,32 @@ createView conn (DatabaseView name definition) = do
         , definition
         ]
 
+-- | 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

From 6fea44f80465280a4441e86593d1786f2024a432 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Thu, 3 Sep 2020 05:43:44 +0000
Subject: [PATCH 02/23] Add `active_pool_owners` pool database view.

---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 28 ++++++++++++++++++++++++++
 1 file changed, 28 insertions(+)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index 1748e75f9c2..116412b2966 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -498,6 +498,7 @@ migrateManually
     -> ManualMigration
 migrateManually _tr =
     ManualMigration $ \conn -> do
+        createView conn activePoolOwners
         createView conn activePoolRegistrations
         createView conn activePoolRetirements
 
@@ -524,6 +525,33 @@ createView conn (DatabaseView name definition) = do
         , definition
         ]
 
+-- | 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

From 48195fc41f6eb52d4d464502c053b2a834169d5e Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Tue, 1 Sep 2020 08:32:54 +0000
Subject: [PATCH 03/23] Add `active_pool_lifecycle_data` pool database view.

---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 31 ++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index 116412b2966..6d68d0a4d80 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -498,6 +498,7 @@ migrateManually
     -> ManualMigration
 migrateManually _tr =
     ManualMigration $ \conn -> do
+        createView conn activePoolLifeCycleData
         createView conn activePoolOwners
         createView conn activePoolRegistrations
         createView conn activePoolRetirements
@@ -525,6 +526,36 @@ createView conn (DatabaseView name definition) = do
         , definition
         ]
 
+-- | Views active lifecycle 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

From 7b10e7070d69972974471d8b10ff04e4ffc1d283 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Fri, 4 Sep 2020 04:16:57 +0000
Subject: [PATCH 04/23] Add operation `listPoolLifeCycleData` to pool database
 layer.

Both SQLite and model implementations are provided.
---
 lib/core/src/Cardano/Pool/DB.hs               |  7 +++
 lib/core/src/Cardano/Pool/DB/MVar.hs          | 10 ++++
 lib/core/src/Cardano/Pool/DB/Sqlite.hs        | 52 +++++++++++++++++++
 .../src/Cardano/Wallet/DB/Sqlite/Types.hs     | 10 ++++
 4 files changed, 79 insertions(+)

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 6d68d0a4d80..cdf47a7675b 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
@@ -372,6 +375,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?
             --
diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs
index 3815bdbff26..e3e2a9c4f7d 100644
--- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs
+++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs
@@ -462,6 +462,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
 

From 078e389f92a19391d05627651a921d45e2b33db3 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Fri, 4 Sep 2020 04:17:49 +0000
Subject: [PATCH 05/23] Use `listPoolLifeCycleData` within `readPoolDbData`.

This replaces a sequence of n database operations with a single database
operation that performs just a single query.
---
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 46 ++++++-------------
 1 file changed, 15 insertions(+), 31 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index d8a82d9f39d..e2931c406aa 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -128,6 +128,8 @@ import Data.Set
     ( Set )
 import Data.Text.Class
     ( ToText (..) )
+import Data.Tuple.Extra
+    ( dupe )
 import Data.Word
     ( Word64 )
 import Fmt
@@ -447,40 +449,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)]
+    lifeCycleData <- listPoolLifeCycleData maxBound
+    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
 

From ce628d946814298926081a991314ff6d459138e9 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Fri, 4 Sep 2020 03:50:33 +0000
Subject: [PATCH 06/23] Pass `currentEpoch` through to `readPoolDbData`.

This makes it possible to filter out retired pools at the SQL query level.
---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index e2931c406aa..b8cd598e374 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -194,7 +194,7 @@ newStakePoolLayer nl db@DBLayer {..} =
     _knownPools
         :: IO (Set PoolId)
     _knownPools =
-        Map.keysSet <$> liftIO (readPoolDbData db)
+        Map.keysSet <$> liftIO (readPoolDbData db minBound)
 
     _listPools
         :: EpochNo
@@ -206,7 +206,7 @@ newStakePoolLayer nl db@DBLayer {..} =
         rawLsqData <- mapExceptT (fmap (first ErrListPoolsNetworkError))
             $ 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.
@@ -449,9 +449,9 @@ combineChainData registrationMap retirementMap prodMap metaMap =
         mRetirementCert =
             Map.lookup (view #poolId registrationCert) retirementMap
 
-readPoolDbData :: DBLayer IO -> IO (Map PoolId PoolDbData)
-readPoolDbData DBLayer {..} = atomically $ do
-    lifeCycleData <- listPoolLifeCycleData maxBound
+readPoolDbData :: DBLayer IO -> EpochNo -> IO (Map PoolId PoolDbData)
+readPoolDbData DBLayer {..} currentEpoch = atomically $ do
+    lifeCycleData <- listPoolLifeCycleData currentEpoch
     let registrationCertificates = lifeCycleData
             & fmap getPoolRegistrationCertificate
             & catMaybes

From 380d33f0441adf8eb2b326cd2dbe530dd2e03c1e Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Fri, 4 Sep 2020 03:51:45 +0000
Subject: [PATCH 07/23] Remove in-memory filtering of retired pools.

This is no longer necessary, as retired pools are now filtered out at
the SQL query level.
---
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 21 ++-----------------
 1 file changed, 2 insertions(+), 19 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index b8cd598e374..9bb17fca1f7 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -208,12 +208,8 @@ newStakePoolLayer nl db@DBLayer {..} =
         let lsqData = combineLsqData rawLsqData
         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
         r <- liftIO $ try $
             sortByReward seed
-            . filter (not . poolIsRetired)
             . map snd
             . Map.toList
             <$> combineDbAndLsqData
@@ -222,11 +218,10 @@ newStakePoolLayer nl db@DBLayer {..} =
                 lsqData
                 dbData
         case r of
-            Left e@(PastHorizon{}) -> throwE (ErrListPoolsPastHorizonException e)
+            Left e@(PastHorizon{}) ->
+                throwE (ErrListPoolsPastHorizonException e)
             Right r' -> pure r'
-
       where
-
         fromErrCurrentNodeTip :: ErrCurrentNodeTip -> ErrListPools
         fromErrCurrentNodeTip = \case
             ErrCurrentNodeTipNetworkUnreachable e ->
@@ -234,18 +229,6 @@ newStakePoolLayer nl db@DBLayer {..} =
             ErrCurrentNodeTipNotFound ->
                 ErrListPoolsNetworkError $ 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.
         --

From f3d6ec5476cd31e53a90ef0943dad008b3ff8cdd Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Fri, 4 Sep 2020 05:53:01 +0000
Subject: [PATCH 08/23] Use a single aggregate query for `readTotalProduction`.

---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index cdf47a7675b..3c3d96c2be0 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -211,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]

From 9eef059b1520a0d73081da75b2c03913bce360bf Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 03:42:22 +0000
Subject: [PATCH 09/23] Add `MultiPoolCertificateSequence` type to test suite.

This type will be used by later commits, to generate sequences of
registration and retirement certificates affecting multiple pools.
---
 .../test/unit/Cardano/Pool/DB/Arbitrary.hs    | 16 ++++++++++
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 30 +++++++++++++++++++
 2 files changed, 46 insertions(+)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
index 15740763a61..fad2ad65b27 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
@@ -9,6 +9,7 @@
 
 module Cardano.Pool.DB.Arbitrary
     ( ListSerializationMethod
+    , MultiPoolCertificateSequence (..)
     , SinglePoolCertificateSequence (..)
     , StakePoolsFixture (..)
     , genStakePoolMetadata
@@ -243,6 +244,21 @@ instance Arbitrary SinglePoolCertificateSequence where
             & fmap (SinglePoolCertificateSequence sharedPoolId)
             & filter isValidSinglePoolCertificateSequence
 
+-- | Represents valid sequences of registration and retirement certificates
+--   for multiple pools.
+--
+newtype MultiPoolCertificateSequence = MultiPoolCertificateSequence
+    { getMultiPoolCertificateSequence :: [SinglePoolCertificateSequence]
+    }
+    deriving (Eq, Show)
+
+instance Arbitrary MultiPoolCertificateSequence where
+    arbitrary = MultiPoolCertificateSequence <$> arbitrary
+    shrink
+        = fmap MultiPoolCertificateSequence
+        . shrink
+        . getMultiPoolCertificateSequence
+
 -- | Indicates a way to serialize a list of lists into a single list.
 --
 data ListSerializationMethod
diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index 27846240e92..5c4ab4f4cdd 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -28,6 +28,7 @@ import Cardano.Pool.DB
     )
 import Cardano.Pool.DB.Arbitrary
     ( ListSerializationMethod
+    , MultiPoolCertificateSequence (..)
     , SinglePoolCertificateSequence (..)
     , StakePoolsFixture (..)
     , genStakePoolMetadata
@@ -222,6 +223,8 @@ properties = do
                 prop_determinePoolLifeCycleStatus_differentPools)
         it "SinglePoolCertificateSequence coverage is adequate"
             (property . const prop_SinglePoolCertificateSequence_coverage)
+        it "MultiPoolCertificateSequence coverage is adequate"
+            (property . const prop_MultiPoolCertificateSequence_coverage)
 
 {-------------------------------------------------------------------------------
                                     Properties
@@ -1264,6 +1267,33 @@ prop_SinglePoolCertificateSequence_coverage
         Registration _ -> Nothing
         Retirement cert -> Just cert
 
+prop_MultiPoolCertificateSequence_coverage
+    :: MultiPoolCertificateSequence
+    -> Property
+prop_MultiPoolCertificateSequence_coverage mpcs = 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"
+    True
+  where
+    certificateCount = L.sum $
+        L.length . getSinglePoolCertificateSequence <$> certificateSequences
+    certificateSequences = getMultiPoolCertificateSequence mpcs
+    poolCount = length certificateSequences
+
 descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation
 descSlotsPerPool pools = do
     let checkIfDesc slots =

From d4f5e0091cce902390fd4d5daa8ee6dd2b7f387c Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 03:46:58 +0000
Subject: [PATCH 10/23] Simplify
 `prop_listRetiredPools_multiplePools_multipleCerts`.

Use `MultiPoolCertificateSequence` to simplify the
`prop_listRetiredPools_multiplePools_multipleCerts` property.
---
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 24 +++----------------
 1 file changed, 3 insertions(+), 21 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index 5c4ab4f4cdd..562097f01c3 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -978,28 +978,11 @@ prop_listRegisteredPools DBLayer {..} entries =
 --
 prop_listRetiredPools_multiplePools_multipleCerts
     :: DBLayer IO
-    -> [SinglePoolCertificateSequence]
+    -> MultiPoolCertificateSequence
     -> 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)
+    DBLayer {..} mpcs serializationMethod = monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
 
@@ -1024,8 +1007,7 @@ prop_listRetiredPools_multiplePools_multipleCerts
                 (Set.fromList retiredPoolsActual)
                 (Set.fromList retiredPoolsExpected)
 
-    certificateCount = length allCertificatesSerialized
-    poolCount = length certificateSequences
+    certificateSequences = getMultiPoolCertificateSequence mpcs
 
     allCertificatesSerialized :: [PoolCertificate]
     allCertificatesSerialized = serializeLists serializationMethod

From e2f15bfe8e264059b87a227b486ec8a77d16505c Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 04:09:23 +0000
Subject: [PATCH 11/23] Add `ListSerializationOrder` to
 `MultiPoolCertificateSequence`.

This makes it possible to provide the following function, which produces
a single, flattened list of pool certificates affecting multiple pools.

```
getMultiPoolCertificateSequence
    :: MultiPoolCertificateSequence -> [PoolCertificate]
```
---
 .../test/unit/Cardano/Pool/DB/Arbitrary.hs    | 32 +++++++++++++------
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 17 ++++------
 2 files changed, 28 insertions(+), 21 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
index fad2ad65b27..7d7a38dcc3f 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
@@ -8,13 +8,12 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Cardano.Pool.DB.Arbitrary
-    ( ListSerializationMethod
-    , MultiPoolCertificateSequence (..)
+    ( MultiPoolCertificateSequence (..)
+    , getMultiPoolCertificateSequence
     , SinglePoolCertificateSequence (..)
     , StakePoolsFixture (..)
     , genStakePoolMetadata
     , isValidSinglePoolCertificateSequence
-    , serializeLists
     ) where
 
 import Prelude
@@ -247,17 +246,30 @@ instance Arbitrary SinglePoolCertificateSequence where
 -- | Represents valid sequences of registration and retirement certificates
 --   for multiple pools.
 --
-newtype MultiPoolCertificateSequence = MultiPoolCertificateSequence
-    { getMultiPoolCertificateSequence :: [SinglePoolCertificateSequence]
+-- Use 'getMultiPoolCertificateSequence' to obtain a single, flattened list
+-- of pool certificates.
+--
+data MultiPoolCertificateSequence = MultiPoolCertificateSequence
+    { getSerializationMethod :: ListSerializationMethod
+    , getSinglePoolSequences :: [SinglePoolCertificateSequence]
     }
     deriving (Eq, Show)
 
 instance Arbitrary MultiPoolCertificateSequence where
-    arbitrary = MultiPoolCertificateSequence <$> arbitrary
-    shrink
-        = fmap MultiPoolCertificateSequence
-        . shrink
-        . getMultiPoolCertificateSequence
+    arbitrary = MultiPoolCertificateSequence
+        <$> arbitrary
+        <*> arbitrary
+    shrink mpcs =
+        [ MultiPoolCertificateSequence (getSerializationMethod mpcs) sequences
+        | sequences <- shrink (getSinglePoolSequences mpcs)
+        ]
+
+getMultiPoolCertificateSequence
+    :: MultiPoolCertificateSequence -> [PoolCertificate]
+getMultiPoolCertificateSequence mpcs =
+    serializeLists
+        (getSerializationMethod mpcs)
+        (getSinglePoolCertificateSequence <$> getSinglePoolSequences mpcs)
 
 -- | Indicates a way to serialize a list of lists into a single list.
 --
diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index 562097f01c3..d24be4cd5d7 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -27,13 +27,12 @@ import Cardano.Pool.DB
     , readPoolLifeCycleStatus
     )
 import Cardano.Pool.DB.Arbitrary
-    ( ListSerializationMethod
-    , MultiPoolCertificateSequence (..)
+    ( MultiPoolCertificateSequence (..)
     , SinglePoolCertificateSequence (..)
     , StakePoolsFixture (..)
     , genStakePoolMetadata
+    , getMultiPoolCertificateSequence
     , isValidSinglePoolCertificateSequence
-    , serializeLists
     )
 import Cardano.Pool.DB.Log
     ( PoolDbLog )
@@ -979,10 +978,9 @@ prop_listRegisteredPools DBLayer {..} entries =
 prop_listRetiredPools_multiplePools_multipleCerts
     :: DBLayer IO
     -> MultiPoolCertificateSequence
-    -> ListSerializationMethod
     -> Property
 prop_listRetiredPools_multiplePools_multipleCerts
-    DBLayer {..} mpcs serializationMethod = monadicIO (setup >> prop)
+    DBLayer {..} mpcs = monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
 
@@ -1007,11 +1005,8 @@ prop_listRetiredPools_multiplePools_multipleCerts
                 (Set.fromList retiredPoolsActual)
                 (Set.fromList retiredPoolsExpected)
 
-    certificateSequences = getMultiPoolCertificateSequence mpcs
-
     allCertificatesSerialized :: [PoolCertificate]
-    allCertificatesSerialized = serializeLists serializationMethod
-        (getSinglePoolCertificateSequence <$> certificateSequences)
+    allCertificatesSerialized = getMultiPoolCertificateSequence mpcs
 
     allPublicationsSerialized
         :: [(CertificatePublicationTime, PoolCertificate)]
@@ -1019,7 +1014,7 @@ prop_listRetiredPools_multiplePools_multipleCerts
         publicationTimes `zip` allCertificatesSerialized
 
     allPoolIds :: [PoolId]
-    allPoolIds = getSinglePoolId <$> certificateSequences
+    allPoolIds = getSinglePoolId <$> getSinglePoolSequences mpcs
 
     publicationTimes :: [CertificatePublicationTime]
     publicationTimes =
@@ -1273,7 +1268,7 @@ prop_MultiPoolCertificateSequence_coverage mpcs = checkCoverage
   where
     certificateCount = L.sum $
         L.length . getSinglePoolCertificateSequence <$> certificateSequences
-    certificateSequences = getMultiPoolCertificateSequence mpcs
+    certificateSequences = getSinglePoolSequences mpcs
     poolCount = length certificateSequences
 
 descSlotsPerPool :: Map PoolId [BlockHeader] -> Expectation

From bc734c7ef73c58a3fb793297d2c0cedaab52664c Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 04:50:38 +0000
Subject: [PATCH 12/23] Further simplify
 `prop_listRetiredPools_multiplePools_multipleCerts`.

---
 lib/core/test/unit/Cardano/Pool/DB/Properties.hs | 14 +++++---------
 1 file changed, 5 insertions(+), 9 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index d24be4cd5d7..115d05e1147 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -986,7 +986,7 @@ prop_listRetiredPools_multiplePools_multipleCerts
 
     prop = do
         run $ atomically $ do
-            mapM_ (uncurry putCertificate) allPublicationsSerialized
+            mapM_ (uncurry putCertificate) allPublications
         lifeCycleStatuses <- run $ atomically $ do
             mapM readPoolLifeCycleStatus allPoolIds
         let poolsMarkedToRetire = catMaybes $
@@ -1005,17 +1005,13 @@ prop_listRetiredPools_multiplePools_multipleCerts
                 (Set.fromList retiredPoolsActual)
                 (Set.fromList retiredPoolsExpected)
 
-    allCertificatesSerialized :: [PoolCertificate]
-    allCertificatesSerialized = getMultiPoolCertificateSequence mpcs
-
-    allPublicationsSerialized
-        :: [(CertificatePublicationTime, PoolCertificate)]
-    allPublicationsSerialized =
-        publicationTimes `zip` allCertificatesSerialized
-
     allPoolIds :: [PoolId]
     allPoolIds = getSinglePoolId <$> getSinglePoolSequences mpcs
 
+    allPublications :: [(CertificatePublicationTime, PoolCertificate)]
+    allPublications =
+        publicationTimes `zip` getMultiPoolCertificateSequence mpcs
+
     publicationTimes :: [CertificatePublicationTime]
     publicationTimes =
         [ CertificatePublicationTime (SlotNo sn) ii

From aeaf61b0674807bb8f96b1b9f97f70db3d5e9892 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 05:08:19 +0000
Subject: [PATCH 13/23] Introduce function `putPoolCertificate` to reduce code
 duplication.

---
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 50 ++++++++-----------
 1 file changed, 22 insertions(+), 28 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index 115d05e1147..af26532d334 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -661,15 +661,15 @@ prop_readPoolLifeCycleStatus
     -> SinglePoolCertificateSequence
     -> Property
 prop_readPoolLifeCycleStatus
-    DBLayer {..} (SinglePoolCertificateSequence sharedPoolId certificates) =
+    db@DBLayer {..} (SinglePoolCertificateSequence sharedPoolId certificates) =
         monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
 
     prop = do
-        actualStatus <- run $ atomically $ do
-            mapM_ (uncurry putCertificate) certificatePublications
-            readPoolLifeCycleStatus sharedPoolId
+        actualStatus <- run $ do
+            mapM_ (uncurry $ putPoolCertificate db) certificatePublications
+            atomically $ readPoolLifeCycleStatus sharedPoolId
         poolsMarkedToRetire <-
             run $ atomically $ listRetiredPools $ EpochNo maxBound
         monitor $ counterexample $ unlines
@@ -729,12 +729,6 @@ prop_readPoolLifeCycleStatus
         , ii <- [0 .. 3]
         ]
 
-    putCertificate cpt = \case
-        Registration cert ->
-            putPoolRegistration cpt cert
-        Retirement cert ->
-            putPoolRetirement cpt cert
-
 prop_rollbackRegistration
     :: DBLayer IO
     -> SlotNo
@@ -865,15 +859,14 @@ prop_removePools
     -> [PoolCertificate]
     -> Property
 prop_removePools
-    DBLayer {..} certificates =
+    db@DBLayer {..} certificates =
         monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
 
     prop = do
         -- Firstly, publish an arbitrary set of pool certificates:
-        run $ atomically $ do
-            mapM_ (uncurry putCertificate) certificatePublications
+        run $ mapM_ (uncurry $ putPoolCertificate db) certificatePublications
         -- Next, read the latest certificates for all pools:
         poolIdsWithRegCertsAtStart <- run poolIdsWithRegCerts
         poolIdsWithRetCertsAtStart <- run poolIdsWithRetCerts
@@ -925,12 +918,6 @@ prop_removePools
         , ii <- [0 .. 3]
         ]
 
-    putCertificate cpt = \case
-        Registration cert ->
-            putPoolRegistration cpt cert
-        Retirement cert ->
-            putPoolRetirement cpt cert
-
     poolIdsWithRegCerts =
         fmap (Set.fromList . fmap (view #poolId . snd) . catMaybes)
             <$> atomically $ mapM readPoolRegistration $ Set.toList pools
@@ -980,13 +967,12 @@ prop_listRetiredPools_multiplePools_multipleCerts
     -> MultiPoolCertificateSequence
     -> Property
 prop_listRetiredPools_multiplePools_multipleCerts
-    DBLayer {..} mpcs = monadicIO (setup >> prop)
+    db@DBLayer {..} mpcs = monadicIO (setup >> prop)
   where
     setup = run $ atomically cleanDB
 
     prop = do
-        run $ atomically $ do
-            mapM_ (uncurry putCertificate) allPublications
+        run $ mapM_ (uncurry $ putPoolCertificate db) allPublications
         lifeCycleStatuses <- run $ atomically $ do
             mapM readPoolLifeCycleStatus allPoolIds
         let poolsMarkedToRetire = catMaybes $
@@ -1019,12 +1005,6 @@ prop_listRetiredPools_multiplePools_multipleCerts
         , ii <- [0 .. 3]
         ]
 
-    putCertificate cpt = \case
-        Registration cert ->
-            putPoolRegistration cpt cert
-        Retirement cert ->
-            putPoolRetirement cpt cert
-
 prop_unfetchedPoolMetadataRefs
     :: DBLayer IO
     -> [PoolRegistrationCertificate]
@@ -1294,3 +1274,17 @@ allPoolProduction DBLayer{..} (StakePoolsFixture pairs _) = atomically $
         [ [ (view #slotNo h, p) | h <- hs ]
         | (p, hs) <- concatMap Map.assocs ms
         ]
+
+-- | Write any kind of pool certificate to the database.
+putPoolCertificate
+    :: DBLayer m
+    -> CertificatePublicationTime
+    -> PoolCertificate
+    -> m ()
+putPoolCertificate
+    DBLayer {atomically, putPoolRegistration, putPoolRetirement}
+    publicationTime = atomically . \case
+        Registration c ->
+            putPoolRegistration publicationTime c
+        Retirement c ->
+            putPoolRetirement publicationTime c

From c8b4106368a99c83e475e6e55355b132c2ed40c4 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 05:19:21 +0000
Subject: [PATCH 14/23] Introduce `testCertificatePublicationTimes` to reduce
 code duplication.

---
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 50 +++++++------------
 1 file changed, 18 insertions(+), 32 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index af26532d334..96b382b1e62 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -575,18 +575,13 @@ prop_multiple_putPoolRegistration_single_readPoolRegistration
 
     certificatePublications
         :: [(CertificatePublicationTime, PoolRegistrationCertificate)]
-    certificatePublications = publicationTimes `zip` certificates
+    certificatePublications =
+        testCertificatePublicationTimes `zip` certificates
 
     mExpectedCertificatePublication = certificatePublications
         & reverse
         & listToMaybe
 
-    publicationTimes =
-        [ CertificatePublicationTime (SlotNo sn) ii
-        | sn <- [0 .. ]
-        , ii <- [0 .. 3]
-        ]
-
     certificates = set #poolId sharedPoolId <$> certificatesManyPoolIds
 
 -- For the same pool, write /multiple/ pool retirement certificates to the
@@ -824,7 +819,7 @@ prop_rollbackRetirement DBLayer{..} certificates =
     rollbackPoint =
         -- Pick a slot that approximately corresponds to the midpoint of the
         -- certificate publication list.
-        publicationTimes
+        testCertificatePublicationTimes
             & drop (length certificates `div` 2)
             & fmap (view #slotNo)
             & listToMaybe
@@ -832,7 +827,7 @@ prop_rollbackRetirement DBLayer{..} certificates =
 
     allPublications
         :: [(CertificatePublicationTime, PoolRetirementCertificate)]
-    allPublications = publicationTimes `zip` certificates
+    allPublications = testCertificatePublicationTimes `zip` certificates
 
     expectedPublications
         :: [(CertificatePublicationTime, PoolRetirementCertificate)]
@@ -842,13 +837,6 @@ prop_rollbackRetirement DBLayer{..} certificates =
                 slotId <= rollbackPoint)
             allPublications
 
-    publicationTimes :: [CertificatePublicationTime]
-    publicationTimes =
-        [ CertificatePublicationTime (SlotNo sn) ii
-        | sn <- [0 .. 3]
-        , ii <- [0 .. 3]
-        ]
-
 -- When we remove pools, check that:
 --
 -- 1. We only remove data relating to the specified pools.
@@ -909,14 +897,8 @@ prop_removePools
 
     certificatePublications
         :: [(CertificatePublicationTime, PoolCertificate)]
-    certificatePublications = publicationTimes `zip` certificates
-
-    publicationTimes :: [CertificatePublicationTime]
-    publicationTimes =
-        [ CertificatePublicationTime (SlotNo sn) ii
-        | sn <- [0 .. 3]
-        , ii <- [0 .. 3]
-        ]
+    certificatePublications =
+        testCertificatePublicationTimes `zip` certificates
 
     poolIdsWithRegCerts =
         fmap (Set.fromList . fmap (view #poolId . snd) . catMaybes)
@@ -996,14 +978,9 @@ prop_listRetiredPools_multiplePools_multipleCerts
 
     allPublications :: [(CertificatePublicationTime, PoolCertificate)]
     allPublications =
-        publicationTimes `zip` getMultiPoolCertificateSequence mpcs
-
-    publicationTimes :: [CertificatePublicationTime]
-    publicationTimes =
-        [ CertificatePublicationTime (SlotNo sn) ii
-        | sn <- [0 .. 3]
-        , ii <- [0 .. 3]
-        ]
+        testCertificatePublicationTimes
+        `zip`
+        getMultiPoolCertificateSequence mpcs
 
 prop_unfetchedPoolMetadataRefs
     :: DBLayer IO
@@ -1288,3 +1265,12 @@ putPoolCertificate
             putPoolRegistration publicationTime c
         Retirement c ->
             putPoolRetirement publicationTime c
+
+-- | A sequence of certificate publication times that is useful for testing.
+--
+testCertificatePublicationTimes :: [CertificatePublicationTime]
+testCertificatePublicationTimes =
+    [ CertificatePublicationTime (SlotNo sn) ii
+    | sn <- [0 ..  ]
+    , ii <- [0 .. 3]
+    ]

From ca84ee93bfa21be4deca1b5d6f55f5ee01aea5f9 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 07:39:57 +0000
Subject: [PATCH 15/23] Allow `PoolLifeCycleStatus` values to be included in
 sets.

---
 lib/core/src/Cardano/Wallet/Primitive/Types.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
index 1896ca08924..d9f497185c4 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -1759,7 +1759,7 @@ data PoolLifeCycleStatus
         PoolRetirementCertificate
         -- ^ Indicates that a pool is registered AND ALSO marked for retirement.
         -- Records the latest registration and retirement certificates.
-    deriving (Eq, Show)
+    deriving (Eq, Ord, Show)
 
 getPoolRegistrationCertificate
     :: PoolLifeCycleStatus -> Maybe PoolRegistrationCertificate

From 56a8af58eb8ccf7730e30ab83e623434f9c80bda Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 07:41:29 +0000
Subject: [PATCH 16/23] Do not generate registration certificates with empty
 owners lists.

Every valid registration certificate must have at least one owner.

Ideally, this should be encoded in the type system, but we make do with
not generating invalid data for now.
---
 .../test/unit/Cardano/Pool/DB/Arbitrary.hs    | 25 +++++++++++--------
 1 file changed, 15 insertions(+), 10 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
index 7d7a38dcc3f..a24b99b3e57 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
@@ -45,7 +45,7 @@ import Cardano.Wallet.Primitive.Types
 import Control.Arrow
     ( second )
 import Control.Monad
-    ( foldM )
+    ( foldM, replicateM )
 import Data.Function
     ( (&) )
 import Data.Generics.Internal.VL.Lens
@@ -70,11 +70,8 @@ import Test.QuickCheck
     , elements
     , frequency
     , genericShrink
-    , listOf
     , oneof
-    , scale
     , shrinkIntegral
-    , shrinkList
     , shuffle
     , vector
     , vectorOf
@@ -159,13 +156,17 @@ instance Arbitrary PoolOwner where
         return $ PoolOwner $ B8.pack (replicate 32 byte)
 
 instance Arbitrary PoolRegistrationCertificate where
-    shrink (PoolRegistrationCertificate p xs m c pl md) =
-        (\p' xs' -> PoolRegistrationCertificate p' xs' m c pl md)
-            <$> shrink p
-            <*> shrinkList (const []) xs
+    shrink (PoolRegistrationCertificate pid owners m c pl md) =
+        (\pid' owners' -> PoolRegistrationCertificate pid' owners' m c pl md)
+            <$> shrink pid
+            <*> shrinkOwners owners
+      where
+        shrinkOwners os =
+            -- A valid registration certificate must have at least one owner:
+            [ps | ps <- shrink os, not (null ps)]
     arbitrary = PoolRegistrationCertificate
         <$> arbitrary
-        <*> scale (`mod` 8) (listOf arbitrary)
+        <*> genOwners
         <*> genPercentage
         <*> fmap Quantity arbitrary
         <*> fmap Quantity arbitrary
@@ -174,7 +175,11 @@ instance Arbitrary PoolRegistrationCertificate where
         genMetadata = (,)
             <$> fmap StakePoolMetadataUrl genURL
             <*> arbitrary
-        genURL  = do
+        genOwners = do
+            -- A valid registration certificate must have at least one owner:
+            ownerCount <- choose (1, 4)
+            replicateM ownerCount arbitrary
+        genURL = do
             protocol <- elements [ "http", "https" ]
             fstP <- elements [ "cardano", "ada", "pool", "staking", "reward" ]
             sndP <- elements [ "rocks", "moon", "digital", "server", "fast" ]

From 1aaf0437a4b191184ca64b0ef57972f0c4a14ef4 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 07:43:17 +0000
Subject: [PATCH 17/23] Rename helper function to
 `firstCertificateIsNotRetirement`.

This more accurately reflects the function's purpose.

We don't actually mind if the list of certificates is empty.
---
 lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
index a24b99b3e57..afc361b7c11 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
@@ -214,14 +214,14 @@ isValidSinglePoolCertificateSequence :: SinglePoolCertificateSequence -> Bool
 isValidSinglePoolCertificateSequence
     (SinglePoolCertificateSequence sharedPoolId certificates) =
         allCertificatesReferToSamePool &&
-        firstCertificateIsRegistration
+        firstCertificateIsNotRetirement
   where
     allCertificatesReferToSamePool =
         all (== sharedPoolId) (getPoolCertificatePoolId <$> certificates)
-    firstCertificateIsRegistration = case certificates of
+    firstCertificateIsNotRetirement = case certificates of
+        []                 -> True
         Registration _ : _ -> True
-        Retirement _ : _ -> False
-        [] -> True
+        Retirement   _ : _ -> False
 
 instance Arbitrary SinglePoolCertificateSequence where
 

From 4902e3ebe6512c69517b1929d79588cdee154476 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Mon, 7 Sep 2020 08:04:30 +0000
Subject: [PATCH 18/23] Add
 `prop_listPoolLifeCycleData_multiplePools_multipleCerts`.

---
 .../test/unit/Cardano/Pool/DB/Properties.hs   | 83 +++++++++++++++++++
 1 file changed, 83 insertions(+)

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
index 96b382b1e62..2361dcf6373 100644
--- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -205,6 +205,8 @@ properties = do
             (property . prop_listRegisteredPools)
         it "prop_listRetiredPools_multiplePools_multipleCerts"
             (property . prop_listRetiredPools_multiplePools_multipleCerts)
+        it "prop_listPoolLifeCycleData_multiplePools_multipleCerts"
+            (property . prop_listPoolLifeCycleData_multiplePools_multipleCerts)
         it "putPoolProduction* . readTotalProduction matches expectations"
             (property . prop_readTotalProduction)
         it "unfetchedPoolMetadataRefs"
@@ -982,6 +984,87 @@ prop_listRetiredPools_multiplePools_multipleCerts
         `zip`
         getMultiPoolCertificateSequence mpcs
 
+-- | Test `listPoolLifeCycleData` by showing that the following operations are
+--   equivalent:
+--
+--   - Calling `listPoolLifeCycleData` once to fetch lifecycle data for all
+--     active pools.
+--
+--   - Calling `readPoolLifeCycleStatus` multiple times, once for each known
+--     pool, and coalescing the results.
+--
+-- The former operation (calling `listPoolLifeCycleStatus` once) is designed to
+-- be efficient, as it delivers its results with only a single database query.
+--
+-- The latter operation (calling `readPoolLifeCycleStatus` multiple times) is
+-- extremely inefficient, but consists of simpler database operations that we
+-- already verify with other properties.
+--
+-- This property tests that both operations give equivalent results, even with
+-- complex sequences of pool registration and retirement certificates.
+--
+prop_listPoolLifeCycleData_multiplePools_multipleCerts
+    :: DBLayer IO
+    -> MultiPoolCertificateSequence
+    -> Property
+prop_listPoolLifeCycleData_multiplePools_multipleCerts
+    db@DBLayer {..} mpcs = monadicIO (setup >> prop)
+  where
+    setup = run $ atomically cleanDB
+
+    prop = do
+        run $ mapM_ (uncurry $ putPoolCertificate db) allPublications
+        lifeCycleDataReadIndividually <- filter isRegistered <$>
+            run (atomically $ mapM readPoolLifeCycleStatus allPoolIds)
+        let poolsMarkedToRetire = catMaybes $
+                getPoolRetirementCertificate <$> lifeCycleDataReadIndividually
+        let epochsToTest =
+                EpochNo minBound :
+                EpochNo maxBound :
+                L.nub (view #retirementEpoch <$> poolsMarkedToRetire)
+        forM_ epochsToTest $ \currentEpoch -> do
+            let lifeCycleDataExpected = Set.fromList $ filter
+                    (not . isRetired currentEpoch)
+                    (lifeCycleDataReadIndividually)
+            lifeCycleDataActual <- Set.fromList <$> run
+                (atomically $ listPoolLifeCycleData currentEpoch)
+            monitor $ counterexample $ unlines
+                [ "\nEpochs to test: "
+                , show epochsToTest
+                , "\nCurrent epoch: "
+                , show currentEpoch
+                , "\nPools marked with a retirement epoch: "
+                , show poolsMarkedToRetire
+                , "\nExpected lifecycle data: "
+                , show lifeCycleDataExpected
+                , "\nActual lifecycle data: "
+                , show lifeCycleDataActual
+                ]
+            assert $ (==)
+                lifeCycleDataExpected
+                lifeCycleDataActual
+
+    isRegistered :: PoolLifeCycleStatus -> Bool
+    isRegistered = \case
+        PoolNotRegistered -> False
+        PoolRegistered {} -> True
+        PoolRegisteredAndRetired {} -> True
+
+    isRetired :: EpochNo -> PoolLifeCycleStatus -> Bool
+    isRetired currentEpoch status = maybe
+        (False)
+        ((<= currentEpoch) . view #retirementEpoch)
+        (getPoolRetirementCertificate status)
+
+    allPoolIds :: [PoolId]
+    allPoolIds = getSinglePoolId <$> getSinglePoolSequences mpcs
+
+    allPublications :: [(CertificatePublicationTime, PoolCertificate)]
+    allPublications =
+        testCertificatePublicationTimes
+        `zip`
+        getMultiPoolCertificateSequence mpcs
+
 prop_unfetchedPoolMetadataRefs
     :: DBLayer IO
     -> [PoolRegistrationCertificate]

From 6c18b542a52408189dfd76fa7a04dc03dcbc84a9 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Tue, 8 Sep 2020 03:26:35 +0000
Subject: [PATCH 19/23] Add `MsgParseFailure` constructor to `PoolDbLog`.

---
 lib/core/src/Cardano/Pool/DB/Log.hs | 21 +++++++++++++++++++++
 1 file changed, 21 insertions(+)

diff --git a/lib/core/src/Cardano/Pool/DB/Log.hs b/lib/core/src/Cardano/Pool/DB/Log.hs
index d9643636409..87c36542a9d 100644
--- a/lib/core/src/Cardano/Pool/DB/Log.hs
+++ b/lib/core/src/Cardano/Pool/DB/Log.hs
@@ -8,6 +8,7 @@
 --
 module Cardano.Pool.DB.Log
     ( PoolDbLog (..)
+    , ParseFailure (..)
     ) where
 
 import Prelude
@@ -22,6 +23,8 @@ import Cardano.Wallet.Logging
     ( BracketLog )
 import Cardano.Wallet.Primitive.Types
     ( EpochNo, PoolId, PoolRetirementCertificate )
+import Data.Text
+    ( Text )
 import Data.Text.Class
     ( ToText (..), toText )
 import Fmt
@@ -31,16 +34,28 @@ import qualified Data.Text as T
 
 data PoolDbLog
     = MsgGeneric DBLog
+    | MsgParseFailure ParseFailure
     | MsgRemovingPool PoolId
     | MsgRemovingRetiredPools [PoolRetirementCertificate]
     | MsgRemovingRetiredPoolsForEpoch EpochNo BracketLog
     deriving (Eq, Show)
 
+data ParseFailure = ParseFailure
+    { parseFailureOperationName
+        :: Text
+      -- ^ The name of the operation in which the parse failure occurred.
+    , parseFailure
+        :: Text
+      -- ^ A description of the parse failure.
+    }
+    deriving (Eq, Show)
+
 instance HasPrivacyAnnotation PoolDbLog
 
 instance HasSeverityAnnotation PoolDbLog where
     getSeverityAnnotation = \case
         MsgGeneric e -> getSeverityAnnotation e
+        MsgParseFailure {} -> Error
         MsgRemovingPool {} -> Notice
         MsgRemovingRetiredPools {} -> Debug
         MsgRemovingRetiredPoolsForEpoch {} -> Debug
@@ -48,6 +63,12 @@ instance HasSeverityAnnotation PoolDbLog where
 instance ToText PoolDbLog where
     toText = \case
         MsgGeneric e -> toText e
+        MsgParseFailure e -> mconcat
+            [ "Unexpected parse failure in '"
+            , parseFailureOperationName e
+            , "'. Description of error: "
+            , parseFailure e
+            ]
         MsgRemovingPool p -> mconcat
             [ "Removing the following pool from the database: "
             , toText p

From 1990df710a84b0715d73d246d02e94d7fdae9d1b Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Tue, 8 Sep 2020 02:55:35 +0000
Subject: [PATCH 20/23] Log parse failures in pool DB operations.

Log parse failures in the following pool DB operations:
  - `readTotalProduction`.
  - `listPoolLifeCycleData`.
  - `listRetiredPools`.

In response to review feedback:

https://github.com/input-output-hk/cardano-wallet/pull/2111#discussion_r484482133
---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 55 +++++++++++++++++---------
 1 file changed, 37 insertions(+), 18 deletions(-)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index 3c3d96c2be0..6177fc59b7b 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -47,7 +47,7 @@ import Cardano.DB.Sqlite
 import Cardano.Pool.DB
     ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus )
 import Cardano.Pool.DB.Log
-    ( PoolDbLog (..) )
+    ( ParseFailure (..), PoolDbLog (..) )
 import Cardano.Wallet.DB.Sqlite.Types
     ( BlockId (..) )
 import Cardano.Wallet.Logging
@@ -78,7 +78,7 @@ import Control.Monad.Trans.Except
 import Control.Tracer
     ( Tracer (..), contramap, natTracer, traceWith )
 import Data.Either
-    ( rights )
+    ( lefts, rights )
 import Data.Function
     ( (&) )
 import Data.Functor
@@ -211,9 +211,15 @@ newDBLayer trace fp timeInterpreter = do
 
             pure (foldl' toMap Map.empty production)
 
-        readTotalProduction =
-            Map.fromList . rights . fmap parseRow <$> rawSql query []
+        readTotalProduction = do
+            parsedRows <- fmap parseRow <$> rawSql query []
+            mapM_ onParseFailure $ lefts parsedRows
+            pure $ Map.fromList $ rights parsedRows
           where
+            onParseFailure = liftIO
+                . traceWith trace
+                . MsgParseFailure
+                . ParseFailure "readTotalProduction"
             query = T.unwords
                 [ "SELECT pool_id, count(pool_id) as block_count"
                 , "FROM pool_production"
@@ -369,20 +375,29 @@ newDBLayer trace fp timeInterpreter = do
                 ]
 
         listRetiredPools epochNo = do
-            let query = T.unwords
-                    [ "SELECT *"
-                    , "FROM active_pool_retirements"
-                    , "WHERE retirement_epoch <= ?;"
-                    ]
-            let parameters = [ toPersistValue epochNo ]
-            let safeCast (Single poolId, Single retirementEpoch) =
-                    PoolRetirementCertificate
-                        <$> fromPersistValue poolId
-                        <*> fromPersistValue retirementEpoch
-            rights . fmap safeCast <$> rawSql query parameters
-
-        listPoolLifeCycleData epochNo =
-            rights . fmap parseRow <$> rawSql query parameters
+            parsedRows <- fmap parseRow <$> rawSql query parameters
+            mapM_ onParseFailure $ lefts parsedRows
+            pure $ rights parsedRows
+          where
+            query = T.unwords
+                [ "SELECT *"
+                , "FROM active_pool_retirements"
+                , "WHERE retirement_epoch <= ?;"
+                ]
+            parameters = [ toPersistValue epochNo ]
+            onParseFailure = liftIO
+                . traceWith trace
+                . MsgParseFailure
+                . ParseFailure "listRetiredPools"
+            parseRow (Single poolId, Single retirementEpoch) =
+                PoolRetirementCertificate
+                    <$> fromPersistValue poolId
+                    <*> fromPersistValue retirementEpoch
+
+        listPoolLifeCycleData epochNo = do
+            parsedRows <- fmap parseRow <$> rawSql query parameters
+            mapM_ onParseFailure $ lefts parsedRows
+            pure $ rights parsedRows
           where
             query = T.unwords
                 [ "SELECT *"
@@ -390,6 +405,10 @@ newDBLayer trace fp timeInterpreter = do
                 , "WHERE retirement_epoch IS NULL OR retirement_epoch > ?;"
                 ]
             parameters = [ toPersistValue epochNo ]
+            onParseFailure = liftIO
+                . traceWith trace
+                . MsgParseFailure
+                . ParseFailure "listPoolLifeCycleData"
             parseRow
                 ( Single fieldPoolId
                 , Single fieldRetirementEpoch

From 5088a2683cbb4c376f418c9f01d6dd7c9ceccd20 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Wed, 9 Sep 2020 05:02:53 +0000
Subject: [PATCH 21/23] Add function `runRawQuery` to reduce code duplication.

---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 67 ++++++++++++++++----------
 1 file changed, 41 insertions(+), 26 deletions(-)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index 6177fc59b7b..cbf47fec792 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -70,7 +70,7 @@ import Cardano.Wallet.Unsafe
 import Control.Exception
     ( bracket, throwIO )
 import Control.Monad
-    ( forM )
+    ( forM, forM_ )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
@@ -78,7 +78,7 @@ import Control.Monad.Trans.Except
 import Control.Tracer
     ( Tracer (..), contramap, natTracer, traceWith )
 import Data.Either
-    ( lefts, rights )
+    ( partitionEithers, rights )
 import Data.Function
     ( (&) )
 import Data.Functor
@@ -104,6 +104,8 @@ import Data.Word
 import Database.Persist.Sql
     ( Entity (..)
     , Filter
+    , PersistValue
+    , RawSql
     , SelectOpt (..)
     , Single (..)
     , deleteWhere
@@ -211,15 +213,9 @@ newDBLayer trace fp timeInterpreter = do
 
             pure (foldl' toMap Map.empty production)
 
-        readTotalProduction = do
-            parsedRows <- fmap parseRow <$> rawSql query []
-            mapM_ onParseFailure $ lefts parsedRows
-            pure $ Map.fromList $ rights parsedRows
+        readTotalProduction = Map.fromList <$> runRawQuery trace
+            (RawQuery "readTotalProduction" query [] parseRow)
           where
-            onParseFailure = liftIO
-                . traceWith trace
-                . MsgParseFailure
-                . ParseFailure "readTotalProduction"
             query = T.unwords
                 [ "SELECT pool_id, count(pool_id) as block_count"
                 , "FROM pool_production"
@@ -374,10 +370,8 @@ newDBLayer trace fp timeInterpreter = do
                 , Desc PoolRegistrationSlotInternalIndex
                 ]
 
-        listRetiredPools epochNo = do
-            parsedRows <- fmap parseRow <$> rawSql query parameters
-            mapM_ onParseFailure $ lefts parsedRows
-            pure $ rights parsedRows
+        listRetiredPools epochNo = runRawQuery trace $
+            RawQuery "listRetiredPools" query parameters parseRow
           where
             query = T.unwords
                 [ "SELECT *"
@@ -385,19 +379,13 @@ newDBLayer trace fp timeInterpreter = do
                 , "WHERE retirement_epoch <= ?;"
                 ]
             parameters = [ toPersistValue epochNo ]
-            onParseFailure = liftIO
-                . traceWith trace
-                . MsgParseFailure
-                . ParseFailure "listRetiredPools"
             parseRow (Single poolId, Single retirementEpoch) =
                 PoolRetirementCertificate
                     <$> fromPersistValue poolId
                     <*> fromPersistValue retirementEpoch
 
-        listPoolLifeCycleData epochNo = do
-            parsedRows <- fmap parseRow <$> rawSql query parameters
-            mapM_ onParseFailure $ lefts parsedRows
-            pure $ rights parsedRows
+        listPoolLifeCycleData epochNo = runRawQuery trace $ RawQuery
+            "listPoolLifeCycleData" query parameters parseRow
           where
             query = T.unwords
                 [ "SELECT *"
@@ -405,10 +393,6 @@ newDBLayer trace fp timeInterpreter = do
                 , "WHERE retirement_epoch IS NULL OR retirement_epoch > ?;"
                 ]
             parameters = [ toPersistValue epochNo ]
-            onParseFailure = liftIO
-                . traceWith trace
-                . MsgParseFailure
-                . ParseFailure "listPoolLifeCycleData"
             parseRow
                 ( Single fieldPoolId
                 , Single fieldRetirementEpoch
@@ -570,6 +554,37 @@ newDBLayer trace fp timeInterpreter = do
                 let cpt = CertificatePublicationTime {slotNo, slotInternalIndex}
                 pure (cpt, cert)
 
+-- | Defines a raw SQL query, runnable with 'runRawQuery'.
+--
+data RawQuery a b = RawQuery
+    { queryName :: Text
+      -- ^ The name of the query.
+    , queryDefinition :: Text
+      -- ^ The SQL definition of the query.
+    , queryParameters :: [PersistValue]
+      -- ^ Parameters of the query.
+    , queryParser :: a -> Either Text b
+      -- ^ A parser for a row of the result.
+    }
+
+-- | Runs a raw SQL query, logging any parse failures that occur.
+--
+runRawQuery
+    :: forall a b. RawSql a
+    => Tracer IO PoolDbLog
+    -> RawQuery a b
+    -> SqlPersistT IO [b]
+runRawQuery trace q = do
+    (failures, results) <- partitionEithers . fmap (queryParser q) <$> rawSql
+        (queryDefinition q)
+        (queryParameters q)
+    forM_ failures
+        $ liftIO
+        . traceWith trace
+        . MsgParseFailure
+        . ParseFailure (queryName q)
+    pure results
+
 migrateManually
     :: Tracer IO PoolDbLog
     -> ManualMigration

From a41adbc859ffb9f10957bc9cf70885a26c2b4c01 Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Tue, 8 Sep 2020 07:57:53 +0000
Subject: [PATCH 22/23] Define `knownPools` in terms of `listRegisteredPools`.

There's no point in fetching the entire set of all pool-related data
when all we really need is the set of valid pool IDs.
---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 9bb17fca1f7..707205e6d25 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -147,6 +147,7 @@ import qualified Cardano.Wallet.Api.Types as Api
 import qualified Data.List as L
 import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 
 --
 -- Stake Pool Layer
@@ -194,7 +195,7 @@ newStakePoolLayer nl db@DBLayer {..} =
     _knownPools
         :: IO (Set PoolId)
     _knownPools =
-        Map.keysSet <$> liftIO (readPoolDbData db minBound)
+        Set.fromList <$> liftIO (atomically listRegisteredPools)
 
     _listPools
         :: EpochNo

From 7aabf90235304e0fe99c4380c089676e9f048f0c Mon Sep 17 00:00:00 2001
From: Jonathan Knowles <jonathan.knowles@iohk.io>
Date: Wed, 9 Sep 2020 09:14:27 +0000
Subject: [PATCH 23/23] Always recreate views when starting the pool worker.

This makes it possible to change the definitions of views as required.
---
 lib/core/src/Cardano/Pool/DB/Sqlite.hs | 15 +++++++++++----
 1 file changed, 11 insertions(+), 4 deletions(-)

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
index cbf47fec792..37743d527f3 100644
--- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -608,11 +608,18 @@ data DatabaseView = DatabaseView
 --
 createView :: Sqlite.Connection -> DatabaseView -> IO ()
 createView conn (DatabaseView name definition) = do
-    query <- Sqlite.prepare conn queryString
-    Sqlite.step query *> Sqlite.finalize query
+    deleteQuery <- Sqlite.prepare conn deleteQueryString
+    Sqlite.step deleteQuery *> Sqlite.finalize deleteQuery
+    createQuery <- Sqlite.prepare conn createQueryString
+    Sqlite.step createQuery *> Sqlite.finalize createQuery
   where
-    queryString = T.unlines
-        [ "CREATE VIEW IF NOT EXISTS"
+    deleteQueryString = T.unlines
+        [ "DROP VIEW IF EXISTS"
+        , name
+        , ";"
+        ]
+    createQueryString = T.unlines
+        [ "CREATE VIEW"
         , name
         , "AS"
         , definition