From 115748fa42992af5afd53fd5cffc04ad80c0f331 Mon Sep 17 00:00:00 2001
From: Yuriy Lazaryev <yuriy.lazaryev@iohk.io>
Date: Wed, 8 Jun 2022 17:23:28 +0200
Subject: [PATCH 1/6] refactor: move stake pool continuation functions to the
 Pools module

---
 lib/shelley/src/Cardano/Wallet/Shelley.hs     |  65 +-------
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 147 ++++++++++++------
 2 files changed, 102 insertions(+), 110 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index a009d053362..5f0735731a9 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -28,10 +28,6 @@ module Cardano.Wallet.Shelley
 
 import Prelude
 
-import Cardano.Pool.DB
-    ( DBLayer (..) )
-import Cardano.Pool.DB.Log
-    ( PoolDbLog )
 import Cardano.Wallet.Api
     ( ApiLayer, ApiV2 )
 import Cardano.Wallet.Api.Server
@@ -82,7 +78,6 @@ import Cardano.Wallet.Primitive.Types
     ( Block
     , NetworkParameters (..)
     , NetworkParameters
-    , PoolMetadataGCStatus (..)
     , ProtocolParameters (..)
     , Settings (..)
     , SlottingParameters (..)
@@ -98,7 +93,7 @@ import Cardano.Wallet.Primitive.Types.RewardAccount
 import Cardano.Wallet.Primitive.Types.Tx
     ( SealedTx )
 import Cardano.Wallet.Registry
-    ( HasWorkerCtx (..), traceAfterThread )
+    ( HasWorkerCtx (..) )
 import Cardano.Wallet.Shelley.Api.Server
     ( server )
 import Cardano.Wallet.Shelley.BlockchainSource
@@ -117,12 +112,7 @@ import Cardano.Wallet.Shelley.Network
 import Cardano.Wallet.Shelley.Network.Discriminant
     ( SomeNetworkDiscriminant (..), networkDiscriminantToId )
 import Cardano.Wallet.Shelley.Pools
-    ( StakePoolLayer (..)
-    , StakePoolLog (..)
-    , monitorMetadata
-    , monitorStakePools
-    , newStakePoolLayer
-    )
+    ( StakePoolLayer (..), withStakePoolDbLayer, withStakePoolLayer )
 import Cardano.Wallet.Shelley.Tracers as Tracers
     ( TracerSeverities
     , Tracers
@@ -139,18 +129,16 @@ import Cardano.Wallet.TokenMetadata
     ( newMetadataClient )
 import Cardano.Wallet.Transaction
     ( TransactionLayer )
-import Control.Monad
-    ( forM_, void, (>=>) )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Cont
     ( ContT (ContT), evalContT )
 import Control.Tracer
-    ( Tracer, contramap, traceWith )
+    ( Tracer, traceWith )
 import Data.Function
     ( (&) )
 import Data.Maybe
-    ( fromJust, fromMaybe )
+    ( fromJust )
 import Data.Proxy
     ( Proxy (..) )
 import Data.Text
@@ -171,14 +159,7 @@ import System.IOManager
     ( withIOManager )
 import Type.Reflection
     ( Typeable )
-import UnliftIO.Concurrent
-    ( forkFinally, forkIOWithUnmask, killThread )
-import UnliftIO.MVar
-    ( modifyMVar_, newMVar )
-import UnliftIO.STM
-    ( newTVarIO )
 
-import qualified Cardano.Pool.DB as PoolDb
 import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Server as Server
 import qualified Cardano.Wallet.DB.Sqlite as Sqlite
@@ -401,44 +382,6 @@ serveWallet
             tokenMetaClient
             coworker
 
-withStakePoolDbLayer
-    :: Tracer IO PoolDbLog
-    -> Maybe FilePath
-    -> Maybe (Pool.DBDecorator IO)
-    -> NetworkLayer IO block
-    -> ContT r IO (PoolDb.DBLayer IO)
-withStakePoolDbLayer poolDbTracer databaseDir poolDbDecorator netLayer =
-    ContT $ Pool.withDecoratedDBLayer
-        (fromMaybe Pool.undecoratedDB poolDbDecorator)
-        poolDbTracer
-        (Pool.defaultFilePath <$> databaseDir)
-        (neverFails "withPoolsMonitoring never forecasts into the future" $
-            timeInterpreter netLayer)
-
-withStakePoolLayer
-    :: Tracer IO StakePoolLog
-    -> Maybe Settings
-    -> PoolDb.DBLayer IO
-    -> NetworkParameters
-    -> NetworkLayer IO (CardanoBlock StandardCrypto)
-    -> ContT ExitCode IO StakePoolLayer
-withStakePoolLayer tr settings dbLayer@DBLayer{..} netParams netLayer =
-    lift $ do
-    gcStatus <- newTVarIO NotStarted
-    forM_ settings $ atomically . putSettings
-    void $ forkFinally
-        (monitorStakePools tr netParams netLayer dbLayer)
-        (traceAfterThread (contramap MsgExitMonitoring tr))
-
-    -- fixme: needs to be simplified as part of ADP-634
-    let NetworkParameters{slottingParameters} = netParams
-        startMetadataThread = forkIOWithUnmask
-            ($ monitorMetadata gcStatus tr slottingParameters dbLayer)
-    metadataThread <- newMVar =<< startMetadataThread
-    let restartMetadataThread = modifyMVar_ metadataThread $
-            killThread >=> const startMetadataThread
-    newStakePoolLayer gcStatus netLayer dbLayer restartMetadataThread
-
 withNtpClient :: Tracer IO NtpTrace -> ContT r IO NtpClient
 withNtpClient tr = do
     iom <- ContT withIOManager
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 4fdf99a49dc..438ab2c0a64 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -1,10 +1,8 @@
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -24,6 +22,8 @@
 -- as provided through @StakePoolLayer@.
 module Cardano.Wallet.Shelley.Pools
     ( StakePoolLayer (..)
+    , withStakePoolLayer
+    , withStakePoolDbLayer
     , newStakePoolLayer
     , monitorStakePools
     , monitorMetadata
@@ -65,6 +65,7 @@ import Cardano.Wallet.Primitive.Slotting
     , TimeInterpreter
     , epochOf
     , interpretQuery
+    , neverFails
     , unsafeExtendSafeZone
     )
 import Cardano.Wallet.Primitive.Types
@@ -109,9 +110,13 @@ import Cardano.Wallet.Shelley.Compatibility
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
 import Control.Monad
-    ( forM, forM_, forever, void, when )
+    ( forM, forM_, forever, void, when, (>=>) )
+import Control.Monad.Cont
+    ( ContT (ContT) )
 import Control.Monad.IO.Class
     ( liftIO )
+import Control.Monad.Trans.Class
+    ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT (..), runExceptT )
 import Control.Monad.Trans.State
@@ -158,24 +163,33 @@ import GHC.Generics
     ( Generic )
 import Ouroboros.Consensus.Cardano.Block
     ( CardanoBlock, HardForkBlock (..) )
+import System.Exit
+    ( ExitCode )
 import System.Random
     ( RandomGen, random )
 import UnliftIO.Concurrent
-    ( forkFinally, killThread, threadDelay )
+    ( forkFinally, forkIOWithUnmask, killThread, threadDelay )
 import UnliftIO.Exception
     ( finally )
 import UnliftIO.IORef
     ( IORef, newIORef, readIORef, writeIORef )
+import UnliftIO.MVar
+    ( modifyMVar_, newMVar )
 import UnliftIO.STM
     ( TBQueue
     , TVar
     , newTBQueue
+    , newTVarIO
     , readTBQueue
     , readTVarIO
     , writeTBQueue
     , writeTVar
     )
 
+import qualified Cardano.Pool.DB as PoolDb
+import Cardano.Pool.DB.Log
+    ( PoolDbLog )
+import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
@@ -218,6 +232,43 @@ data StakePoolLayer = StakePoolLayer
     , getGCMetadataStatus :: IO PoolMetadataGCStatus
     }
 
+withStakePoolLayer
+    :: Tracer IO StakePoolLog
+    -> Maybe Settings
+    -> PoolDb.DBLayer IO
+    -> NetworkParameters
+    -> NetworkLayer IO (CardanoBlock StandardCrypto)
+    -> ContT ExitCode IO StakePoolLayer
+withStakePoolLayer tr settings dbLayer@DBLayer{..} netParams netLayer = lift do
+    gcStatus <- newTVarIO NotStarted
+    forM_ settings $ atomically . putSettings
+    void $ forkFinally
+        (monitorStakePools tr netParams netLayer dbLayer)
+        (traceAfterThread (contramap MsgExitMonitoring tr))
+
+    -- fixme: needs to be simplified as part of ADP-634
+    let NetworkParameters{slottingParameters} = netParams
+        startMetadataThread = forkIOWithUnmask
+            ($ monitorMetadata gcStatus tr slottingParameters dbLayer)
+    metadataThread <- newMVar =<< startMetadataThread
+    let restartMetadataThread = modifyMVar_ metadataThread $
+            killThread >=> const startMetadataThread
+    newStakePoolLayer gcStatus netLayer dbLayer restartMetadataThread
+
+withStakePoolDbLayer
+    :: Tracer IO PoolDbLog
+    -> Maybe FilePath
+    -> Maybe (Pool.DBDecorator IO)
+    -> NetworkLayer IO block
+    -> ContT r IO (PoolDb.DBLayer IO)
+withStakePoolDbLayer poolDbTracer databaseDir poolDbDecorator netLayer =
+    ContT $ Pool.withDecoratedDBLayer
+        (fromMaybe Pool.undecoratedDB poolDbDecorator)
+        poolDbTracer
+        (Pool.defaultFilePath <$> databaseDir)
+        (neverFails "withPoolsMonitoring never forecasts into the future" $
+            timeInterpreter netLayer)
+
 newStakePoolLayer
     :: forall sc. ()
     => TVar PoolMetadataGCStatus
@@ -225,16 +276,16 @@ newStakePoolLayer
     -> DBLayer IO
     -> IO ()
     -> IO StakePoolLayer
-newStakePoolLayer gcStatus nl db@DBLayer {..} restartSyncThread = do
+newStakePoolLayer gcStatus nl db@DBLayer {..} restartSyncThread =
     pure $ StakePoolLayer
-        { getPoolLifeCycleStatus = _getPoolLifeCycleStatus
-        , knownPools = _knownPools
-        , listStakePools = _listPools
-        , forceMetadataGC = _forceMetadataGC
-        , putSettings = _putSettings
-        , getSettings = _getSettings
-        , getGCMetadataStatus = _getGCMetadataStatus
-        }
+    { getPoolLifeCycleStatus = _getPoolLifeCycleStatus
+    , knownPools = _knownPools
+    , listStakePools = _listPools
+    , forceMetadataGC = _forceMetadataGC
+    , putSettings = _putSettings
+    , getSettings = _getSettings
+    , getGCMetadataStatus = _getGCMetadataStatus
+    }
   where
     _getPoolLifeCycleStatus
         :: PoolId -> IO PoolLifeCycleStatus
@@ -406,7 +457,7 @@ combineDbAndLsqData ti nOpt lsqData =
             (interpretQuery (unsafeExtendSafeZone ti) . toApiEpochInfo)
             mRetirementEpoch
         pure $ Api.ApiStakePool
-            { Api.id = (ApiT pid)
+            { Api.id = ApiT pid
             , Api.metrics = Api.ApiStakePoolMetrics
                 { Api.nonMyopicMemberRewards = Api.coinToQuantity prew
                 , Api.relativeStake = Quantity pstk
@@ -442,7 +493,7 @@ combineLsqData StakePoolsSummary{nOpt, rewards, stake} =
     Map.merge stakeButNoRewards rewardsButNoStake bothPresent stake rewards
   where
     -- calculate the saturation from the relative stake
-    sat s = fromRational $ (getPercentage s) / (1 / fromIntegral nOpt)
+    sat s = fromRational $ getPercentage s / (1 / fromIntegral nOpt)
 
     -- If we fetch non-myopic member rewards of pools using the wallet
     -- balance of 0, the resulting map will be empty. So we set the rewards
@@ -484,7 +535,7 @@ combineChainData registrationMap retirementMap prodMap metaMap delistedSet =
             registrationMap
             prodMap
   where
-    registeredNoProductions = traverseMissing $ \_k cert ->
+    registeredNoProductions = traverseMissing $ \_k cert ->
         pure (cert, Quantity 0)
 
     -- Ignore blocks produced by BFT nodes.
@@ -583,7 +634,7 @@ monitorStakePools tr (NetworkParameters gp sp _pp) nl DBLayer{..} =
         -> NonEmpty (CardanoBlock StandardCrypto)
         -> BlockHeader
         -> IO ()
-    forward latestGarbageCollectionEpochRef blocks _ = do
+    forward latestGarbageCollectionEpochRef blocks _ =
         atomically $ forAllAndLastM blocks forAllBlocks forLastBlock
       where
         forAllBlocks = \case
@@ -711,7 +762,7 @@ monitorMetadata
     -> SlottingParameters
     -> DBLayer IO
     -> IO ()
-monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
+monitorMetadata gcStatus tr sp db@DBLayer{..} = do
     settings <- atomically readSettings
     manager <- newManager defaultManagerSettings
 
@@ -733,27 +784,25 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
 
         _ -> pure NoSmashConfigured
 
-    if  | health == Available || health == NoSmashConfigured -> do
-            case poolMetadataSource settings of
-                FetchNone -> do
-                    STM.atomically $ writeTVar gcStatus NotApplicable
-
-                FetchDirect -> do
-                    STM.atomically $ writeTVar gcStatus NotApplicable
-                    void $ fetchMetadata manager [identityUrlBuilder]
-
-                FetchSMASH (unSmashServer -> uri) -> do
-                    STM.atomically $ writeTVar gcStatus NotStarted
-                    let getDelistedPools =
-                            fetchDelistedPools trFetch uri manager
-                    tid <- forkFinally
-                        (gcDelistedPools gcStatus tr db getDelistedPools)
-                        (traceAfterThread (contramap MsgGCThreadExit tr))
-                    void $ fetchMetadata manager [registryUrlBuilder uri]
-                        `finally` killThread tid
-
-        | otherwise ->
-            traceWith tr MsgSMASHUnreachable
+    if health == Available || health == NoSmashConfigured then (do
+        case poolMetadataSource settings of
+            FetchNone -> do
+                STM.atomically $ writeTVar gcStatus NotApplicable
+
+            FetchDirect -> do
+                STM.atomically $ writeTVar gcStatus NotApplicable
+                void $ fetchMetadata manager [identityUrlBuilder]
+
+            FetchSMASH (unSmashServer -> uri) -> do
+                STM.atomically $ writeTVar gcStatus NotStarted
+                let getDelistedPools =
+                        fetchDelistedPools trFetch uri manager
+                tid <- forkFinally
+                    (gcDelistedPools gcStatus tr db getDelistedPools)
+                    (traceAfterThread (contramap MsgGCThreadExit tr))
+                void $ fetchMetadata manager [registryUrlBuilder uri]
+                    `finally` killThread tid) else
+        traceWith tr MsgSMASHUnreachable
   where
     trFetch = contramap MsgFetchPoolMetadata tr
 
@@ -769,16 +818,16 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
             when (null refs) $ do
                 traceWith tr $ MsgFetchTakeBreak blockFrequency
                 threadDelay blockFrequency
-            forM refs $ \k@(pid, url, hash) -> k <$ withAvailableSeat inFlights (do
+            forM refs $ \k@(pid, url, hash) -> k <$ withAvailableSeat inFlights (
                 fetchFromRemote trFetch strategies manager pid url hash >>= \case
-                    Nothing ->
-                        atomically $ do
-                            settings' <- readSettings
-                            when (settings == settings') $ putFetchAttempt (url, hash)
-                    Just meta -> do
-                        atomically $ do
-                            settings' <- readSettings
-                            when (settings == settings') $ putPoolMetadata hash meta
+                Nothing ->
+                    atomically $ do
+                        settings' <- readSettings
+                        when (settings == settings') $ putFetchAttempt (url, hash)
+                Just meta -> do
+                    atomically $ do
+                        settings' <- readSettings
+                        when (settings == settings') $ putPoolMetadata hash meta
                 )
       where
         -- Twice 'maxInFlight' so that, when removing keys currently in flight,

From 1feb1e2c67f78cd45d578a7998df24fe5696f1a4 Mon Sep 17 00:00:00 2001
From: Yuriy Lazaryev <yuriy.lazaryev@iohk.io>
Date: Thu, 9 Jun 2022 11:00:37 +0200
Subject: [PATCH 2/6] feature: dummy blockfrost stake pool layer

---
 lib/shelley/src/Cardano/Wallet/Shelley.hs     | 32 +++---
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 97 ++++++++++---------
 2 files changed, 73 insertions(+), 56 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index 5f0735731a9..80613e21351 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -112,7 +112,11 @@ import Cardano.Wallet.Shelley.Network
 import Cardano.Wallet.Shelley.Network.Discriminant
     ( SomeNetworkDiscriminant (..), networkDiscriminantToId )
 import Cardano.Wallet.Shelley.Pools
-    ( StakePoolLayer (..), withStakePoolDbLayer, withStakePoolLayer )
+    ( StakePoolLayer (..)
+    , withBlockfrostStakePoolLayer
+    , withNodeStakePoolLayer
+    , withStakePoolDbLayer
+    )
 import Cardano.Wallet.Shelley.Tracers as Tracers
     ( TracerSeverities
     , Tracers
@@ -232,17 +236,21 @@ serveWallet
         network
         netParams
         sTolerance
-    stakePoolDbLayer <- withStakePoolDbLayer
-        poolsDbTracer
-        databaseDir
-        mPoolDatabaseDecorator
-        netLayer
-    stakePoolLayer <- withStakePoolLayer
-        poolsEngineTracer
-        settings
-        stakePoolDbLayer
-        netParams
-        netLayer
+    stakePoolLayer <- case blockchainSource of
+        NodeSource _ _ -> do
+            stakePoolDbLayer <- withStakePoolDbLayer
+                poolsDbTracer
+                databaseDir
+                mPoolDatabaseDecorator
+                netLayer
+            withNodeStakePoolLayer
+                poolsEngineTracer
+                settings
+                stakePoolDbLayer
+                netParams
+                netLayer
+        BlockfrostSource bfProject -> do
+            withBlockfrostStakePoolLayer poolsEngineTracer bfProject
     randomApi <- withRandomApi netLayer
     icarusApi  <- withIcarusApi netLayer
     shelleyApi <- withShelleyApi netLayer
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 438ab2c0a64..96160687ec6 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -22,7 +22,8 @@
 -- as provided through @StakePoolLayer@.
 module Cardano.Wallet.Shelley.Pools
     ( StakePoolLayer (..)
-    , withStakePoolLayer
+    , withBlockfrostStakePoolLayer
+    , withNodeStakePoolLayer
     , withStakePoolDbLayer
     , newStakePoolLayer
     , monitorStakePools
@@ -41,6 +42,8 @@ import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Pool.DB
     ( DBLayer (..), ErrPointAlreadyExists (..), readPoolLifeCycleStatus )
+import Cardano.Pool.DB.Log
+    ( PoolDbLog )
 import Cardano.Pool.Metadata
     ( Manager
     , StakePoolMetadataFetchLog
@@ -186,9 +189,8 @@ import UnliftIO.STM
     , writeTVar
     )
 
+import qualified Blockfrost.Client as BF
 import qualified Cardano.Pool.DB as PoolDb
-import Cardano.Pool.DB.Log
-    ( PoolDbLog )
 import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Data.List as L
@@ -232,14 +234,14 @@ data StakePoolLayer = StakePoolLayer
     , getGCMetadataStatus :: IO PoolMetadataGCStatus
     }
 
-withStakePoolLayer
+withNodeStakePoolLayer
     :: Tracer IO StakePoolLog
     -> Maybe Settings
     -> PoolDb.DBLayer IO
     -> NetworkParameters
     -> NetworkLayer IO (CardanoBlock StandardCrypto)
     -> ContT ExitCode IO StakePoolLayer
-withStakePoolLayer tr settings dbLayer@DBLayer{..} netParams netLayer = lift do
+withNodeStakePoolLayer tr settings dbLayer@DBLayer{..} netParams netLayer = lift do
     gcStatus <- newTVarIO NotStarted
     forM_ settings $ atomically . putSettings
     void $ forkFinally
@@ -269,6 +271,21 @@ withStakePoolDbLayer poolDbTracer databaseDir poolDbDecorator netLayer =
         (neverFails "withPoolsMonitoring never forecasts into the future" $
             timeInterpreter netLayer)
 
+withBlockfrostStakePoolLayer
+    :: Tracer IO StakePoolLog
+    -> BF.Project
+    -> ContT r IO StakePoolLayer
+withBlockfrostStakePoolLayer _tr _project =
+    ContT \k -> k StakePoolLayer
+        { getPoolLifeCycleStatus = \_poolId -> pure PoolNotRegistered
+        , knownPools = pure Set.empty
+        , listStakePools = \_epochNo _coin -> pure []
+        , forceMetadataGC = pure ()
+        , putSettings = \_settings -> pure ()
+        , getSettings = pure $ Settings FetchNone
+        , getGCMetadataStatus = pure NotApplicable
+        }
+
 newStakePoolLayer
     :: forall sc. ()
     => TVar PoolMetadataGCStatus
@@ -277,64 +294,56 @@ newStakePoolLayer
     -> IO ()
     -> IO StakePoolLayer
 newStakePoolLayer gcStatus nl db@DBLayer {..} restartSyncThread =
-    pure $ StakePoolLayer
-    { getPoolLifeCycleStatus = _getPoolLifeCycleStatus
-    , knownPools = _knownPools
-    , listStakePools = _listPools
-    , forceMetadataGC = _forceMetadataGC
-    , putSettings = _putSettings
-    , getSettings = _getSettings
-    , getGCMetadataStatus = _getGCMetadataStatus
-    }
+    pure StakePoolLayer
+        { getPoolLifeCycleStatus = _getPoolLifeCycleStatus
+        , knownPools = _knownPools
+        , listStakePools = _listPools
+        , forceMetadataGC = _forceMetadataGC
+        , putSettings = _putSettings
+        , getSettings = _getSettings
+        , getGCMetadataStatus = _getGCMetadataStatus
+        }
   where
-    _getPoolLifeCycleStatus
-        :: PoolId -> IO PoolLifeCycleStatus
-    _getPoolLifeCycleStatus pid =
-        liftIO $ atomically $ readPoolLifeCycleStatus pid
+    _getPoolLifeCycleStatus :: PoolId -> IO PoolLifeCycleStatus
+    _getPoolLifeCycleStatus pid = atomically $ readPoolLifeCycleStatus pid
 
-    _knownPools
-        :: IO (Set PoolId)
-    _knownPools =
-        Set.fromList <$> liftIO (atomically listRegisteredPools)
+    _knownPools :: IO (Set PoolId)
+    _knownPools = Set.fromList <$> liftIO (atomically listRegisteredPools)
 
-    _putSettings :: Settings -> IO ()
-    _putSettings settings = do
-        atomically (gcMetadata >> putSettings settings)
-        restartSyncThread
+    _getSettings :: IO Settings
+    _getSettings = atomically readSettings
 
+    _putSettings :: Settings -> IO ()
+    _putSettings settings =
+        atomically (gcMetadata >> putSettings settings) *> restartSyncThread
       where
         -- clean up metadata table if the new sync settings suggests so
         gcMetadata = do
             oldSettings <- readSettings
-            case (poolMetadataSource oldSettings, poolMetadataSource settings) of
-                (_, FetchNone) -> -- this is necessary if it's e.g. the first time
-                                  -- we start the server with the new feature
-                                  -- and the database has still stuff in it
+            case ( poolMetadataSource oldSettings
+                 , poolMetadataSource settings ) of
+                (_, FetchNone) ->
+                    -- this is necessary if it's e.g. the first time
+                    -- we start the server with the new feature
+                    -- and the database has still stuff in it
                     removePoolMetadata
-                (old, new)
-                    | old /= new -> removePoolMetadata
+                (old, new) | old /= new -> removePoolMetadata
                 _ -> pure ()
 
-    _getSettings :: IO Settings
-    _getSettings = liftIO $ atomically readSettings
-
     _listPools
         :: EpochNo
         -- Exclude all pools that retired in or before this epoch.
         -> Coin
         -> IO [Api.ApiStakePool]
     _listPools currentEpoch userStake = do
-        rawLsqData <- liftIO $ stakeDistribution nl userStake
-        let lsqData = combineLsqData rawLsqData
-        dbData <- liftIO $ readPoolDbData db currentEpoch
-        seed <- liftIO $ atomically readSystemSeed
-        liftIO $ sortByReward seed
-            . map snd
-            . Map.toList
-            <$> combineDbAndLsqData
+        rawLsqData <- stakeDistribution nl userStake
+        dbData <- readPoolDbData db currentEpoch
+        seed <- atomically readSystemSeed
+        sortByReward seed . map snd . Map.toList <$>
+            combineDbAndLsqData
                 (timeInterpreter nl)
                 (nOpt rawLsqData)
-                lsqData
+                (combineLsqData rawLsqData)
                 dbData
       where
         -- Sort by non-myopic member rewards, making sure to also randomly sort

From 68a6859934acb8155166a221b22531e918feeb9d Mon Sep 17 00:00:00 2001
From: Yuriy Lazaryev <yuriy.lazaryev@iohk.io>
Date: Thu, 9 Jun 2022 11:32:40 +0200
Subject: [PATCH 3/6] Extract Monad & Error modules from Blockfrost

---
 lib/shelley/cardano-wallet.cabal              |   2 +
 .../Wallet/Shelley/Network/Blockfrost.hs      | 122 ++++--------------
 .../Shelley/Network/Blockfrost/Error.hs       |  41 ++++++
 .../Shelley/Network/Blockfrost/Monad.hs       |  71 ++++++++++
 4 files changed, 139 insertions(+), 97 deletions(-)
 create mode 100644 lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
 create mode 100644 lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs

diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal
index b0d526d2d7d..c8e8437409b 100644
--- a/lib/shelley/cardano-wallet.cabal
+++ b/lib/shelley/cardano-wallet.cabal
@@ -120,7 +120,9 @@ library
       Cardano.Wallet.Shelley.Compatibility.Ledger
       Cardano.Wallet.Shelley.Network
       Cardano.Wallet.Shelley.Network.Blockfrost
+      Cardano.Wallet.Shelley.Network.Blockfrost.Error
       Cardano.Wallet.Shelley.Network.Blockfrost.Fixture
+      Cardano.Wallet.Shelley.Network.Blockfrost.Monad
       Cardano.Wallet.Shelley.Network.Discriminant
       Cardano.Wallet.Shelley.Network.Node
       Cardano.Wallet.Shelley.Transaction
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
index 40145cb2b2e..d0536cb0e07 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -29,11 +27,7 @@ module Cardano.Wallet.Shelley.Network.Blockfrost
 
     -- * Internal
     getPoolPerformanceEstimate,
-    eraByEpoch,
-    newClientConfig,
-    BFM (..),
-    runBFM,
-    BlockfrostError (..),
+    eraByEpoch
   )
 where
 
@@ -138,28 +132,26 @@ import Cardano.Wallet.Primitive.Types.TokenBundle
     ( TokenBundle (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Tx (..), TxIn (..), TxOut (..), TxScriptValidity (..), TxSize (..) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Error
+    ( BlockfrostError (..) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Monad
+    ( BFM )
 import Cardano.Wallet.Shelley.Network.Discriminant
     ( SomeNetworkDiscriminant (..), networkDiscriminantToId )
 import Control.Concurrent
     ( threadDelay )
 import Control.Concurrent.Async.Lifted
     ( concurrently, forConcurrently, mapConcurrently )
-import Control.Exception
-    ( throwIO )
 import Control.Monad
-    ( forever, join, unless, (<=<) )
-import Control.Monad.Base
-    ( MonadBase )
+    ( forever, join, unless )
 import Control.Monad.Error.Class
-    ( MonadError (catchError), liftEither, throwError )
+    ( MonadError, liftEither, throwError )
 import Control.Monad.IO.Class
     ( MonadIO (liftIO) )
-import Control.Monad.Reader
-    ( MonadReader, ReaderT (runReaderT), ask, asks )
 import Control.Monad.Trans.Control
     ( MonadBaseControl )
 import Control.Monad.Trans.Except
-    ( ExceptT (..), runExceptT )
+    ( ExceptT (..) )
 import Data.Align
     ( align )
 import Data.Bifunctor
@@ -202,7 +194,7 @@ import Data.Set
 import Data.Text
     ( Text )
 import Data.Text.Class
-    ( FromText (fromText), TextDecodingError (..), ToText (..) )
+    ( FromText (fromText), ToText (..) )
 import Data.These
     ( These (That, These, This) )
 import Data.Traversable
@@ -213,22 +205,16 @@ import GHC.OldList
     ( sortOn )
 import Money
     ( Discrete' )
-import Network.HTTP.Types
-    ( status404 )
 import Ouroboros.Consensus.Cardano.Block
     ( CardanoBlock, StandardCrypto )
 import Ouroboros.Consensus.HardFork.History.EraParams
     ( EraParams (..), SafeZone (StandardSafeZone, UnsafeIndefiniteSafeZone) )
 import Ouroboros.Consensus.HardFork.History.Summary
     ( Bound (..), EraEnd (..), EraSummary (..), Summary (..) )
-import Servant.Client
-    ( runClientM )
 import Text.Read
     ( readEither )
 import UnliftIO.Async
     ( async, link )
-import UnliftIO.Exception
-    ( Exception )
 import UnliftIO.STM
     ( TChan
     , atomically
@@ -245,6 +231,7 @@ import qualified Cardano.Slotting.Time as ST
 import qualified Cardano.Wallet.Network.Light as LN
 import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
 import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Fixture as Fixture
+import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Monad as BFM
 import qualified Data.Aeson as Aeson
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Strict as Map
@@ -254,33 +241,11 @@ import qualified Data.Text as T
 import qualified Data.Vector as V
 import qualified Ouroboros.Consensus.HardFork.History.Qry as HF
 import qualified Ouroboros.Consensus.Util.Counting as UC
-import qualified Servant.Client as Servant
 
 {-------------------------------------------------------------------------------
     NetworkLayer
 -------------------------------------------------------------------------------}
 
-data BlockfrostError
-    = ClientError Servant.ClientError
-    | NoSlotError BF.Block
-    | IntegralCastError String
-    | InvalidBlockHash BF.BlockHash TextDecodingError
-    | InvalidTxMetadataLabel String
-    | InvalidTxMetadataValue String
-    | InvalidTxHash Text TextDecodingError
-    | InvalidAddress Text TextDecodingError
-    | InvalidPoolId Text TextDecodingError
-    | PoolStakePercentageError Coin Coin
-    | InvalidDecentralizationLevelPercentage Double
-    | InvalidUtxoInputAmount BF.UtxoInput
-    | InvalidUtxoOutputAmount BF.UtxoOutput
-    | UnknownEraForEpoch EpochNo
-    deriving (Show, Eq)
-
-newtype BlockfrostException = BlockfrostException BlockfrostError
-    deriving stock (Show)
-    deriving anyclass (Exception)
-
 data Log
     = MsgTipReceived BlockHeader
     | MsgTipWatcherRegistered
@@ -387,7 +352,7 @@ withNetworkLayer
     -> (NetworkLayer IO (CardanoBlock StandardCrypto) -> IO a)
     -> IO a
 withNetworkLayer tr network np project k = do
-    bfConfig <- newClientConfig project
+    bfConfig <- BFM.newClientConfig project
     tipBroadcast <- newBroadcastTChanIO
     link =<< async (pollNodeTip bfConfig tipBroadcast)
     k NetworkLayer
@@ -416,7 +381,7 @@ withNetworkLayer tr network np project k = do
 
     currentNodeTip :: BF.ClientConfig -> IO BlockHeader
     currentNodeTip bfConfig = do
-        tip <- runBFM bfConfig $ fromBlockfrostM =<< BF.getLatestBlock
+        tip <- BFM.run bfConfig $ fromBlockfrostM =<< BF.getLatestBlock
         traceWith tr $ MsgFetchedLatestBlockHeader tip
         pure tip
 
@@ -424,7 +389,7 @@ withNetworkLayer tr network np project k = do
     pollNodeTip bfConfig nodeTip = do
         lastTip <- atomically $ dupTChan nodeTip
         link =<< async =<< forever do
-            header <- runBFM bfConfig $ fromBlockfrostM =<< BF.getLatestBlock
+            header <- BFM.run bfConfig $ fromBlockfrostM =<< BF.getLatestBlock
             atomically do
                 lastHeader <- tryReadTChan lastTip
                 unless (lastHeader == Just header) do
@@ -441,11 +406,11 @@ withNetworkLayer tr network np project k = do
 
     currentProtocolParameters :: BF.ClientConfig -> IO ProtocolParameters
     currentProtocolParameters bfConfig =
-        runBFM bfConfig $ liftEither . fromBlockfrostPP networkId
+        BFM.run bfConfig $ liftEither . fromBlockfrostPP networkId
             =<< BF.getLatestEpochProtocolParams
 
     currentSlottingParameters :: BF.ClientConfig -> IO SlottingParameters
-    currentSlottingParameters bfConfig = runBFM bfConfig do
+    currentSlottingParameters bfConfig = BFM.run bfConfig do
         liftIO $ traceWith tr MsgCurrentSlottingParameters
         BF.EpochInfo{_epochInfoEpoch} <- BF.getLatestEpoch
         epochNo <- fromBlockfrostM _epochInfoEpoch
@@ -466,7 +431,7 @@ withNetworkLayer tr network np project k = do
 
     currentNodeEra :: BF.ClientConfig -> IO AnyCardanoEra
     currentNodeEra bfConfig = do
-        (era, epoch) <- runBFM bfConfig do
+        (era, epoch) <- BFM.run bfConfig do
             BF.EpochInfo{_epochInfoEpoch} <- BF.getLatestEpoch
             latestEpoch <- fromBlockfrostM _epochInfoEpoch
             latestEra <- liftEither $ eraByEpoch networkId latestEpoch
@@ -488,10 +453,10 @@ withNetworkLayer tr network np project k = do
     fetchNetworkRewardAccountBalances
         (SomeNetworkDiscriminant (Proxy :: Proxy nd)) bfConfig accounts = do
             traceWith tr MsgFetchNetworkRewardAccountBalances
-            runBFM bfConfig $ Map.fromList . catMaybes <$>
+            BFM.run bfConfig $ Map.fromList . catMaybes <$>
                 for (Set.toList accounts) \rewardAccount -> do
                     let addr = BF.mkAddress $ encodeStakeAddress @nd rewardAccount
-                    maybe404 (BF.getAccount addr)
+                    BFM.maybe404 (BF.getAccount addr)
                         >>= traverse \BF.AccountInfo{..} ->
                             (rewardAccount,) . Coin <$>
                                 fromIntegral @_ @Integer _accountInfoRewardsSum
@@ -517,7 +482,7 @@ withNetworkLayer tr network np project k = do
         bfConfig
         follower = do
             let runBF :: forall a. BFM a -> IO a
-                runBF = runBFM bfConfig
+                runBF = BFM.run bfConfig
             AnyCardanoEra era <- currentNodeEra bfConfig
             let sp = slottingParameters np
             let stabilityWindow =
@@ -580,7 +545,7 @@ withNetworkLayer tr network np project k = do
                     runBF $ fromBlockEvents <$> case addrOrAcc of
                         Left address -> do
                             txs <- BF.allPages \paged ->
-                                empty404 $ BF.getAddressTransactions'
+                                BFM.empty404 $ BF.getAddressTransactions'
                                     (BF.Address (encodeAddress @nd address))
                                     paged
                                     BF.Ascending
@@ -600,10 +565,10 @@ withNetworkLayer tr network np project k = do
                             let address = BF.Address $ encodeStakeAddress @nd account
                             regTxHashes <-
                                 fmap BF._accountRegistrationTxHash
-                                    <$> empty404 (BF.getAccountRegistrations address)
+                                    <$> BFM.empty404 (BF.getAccountRegistrations address)
                             delTxHashes <-
                                 fmap BF._accountDelegationTxHash
-                                    <$> empty404 (BF.getAccountDelegations address)
+                                    <$> BFM.empty404 (BF.getAccountDelegations address)
                             blockEventsRegDeleg <-
                                 forConcurrently (regTxHashes <> delTxHashes) \hash -> do
                                     (tx@BF.Transaction{_transactionIndex}, dcerts) <-
@@ -618,7 +583,7 @@ withNetworkLayer tr network np project k = do
                                             (\(n, dc) -> ((txIndex, n), dc))
                                                 <$> zip [0 ..] dcerts
                                         )
-                            ws <- empty404 (BF.getAccountWithdrawals address)
+                            ws <- BFM.empty404 (BF.getAccountWithdrawals address)
                             blockEventsWithdraw <-
                                 forConcurrently ws \BF.AccountWithdrawal{..} -> do
                                     (bftx@BF.Transaction{_transactionIndex}, tx) <-
@@ -671,7 +636,7 @@ withNetworkLayer tr network np project k = do
             void $ LN.lightSync (MsgLightLayerLog >$< tr) lightSyncSource follower
 
     syncProgress :: BF.ClientConfig -> SlotNo -> IO SyncProgress
-    syncProgress bfConfig s = runBFM bfConfig do
+    syncProgress bfConfig s = BFM.run bfConfig do
         BF.Block {_blockSlot} <- BF.getLatestBlock
         let latestSlot = maybe 0 BF.unSlot _blockSlot
             currentSlot = fromIntegral (unSlotNo s)
@@ -681,7 +646,7 @@ withNetworkLayer tr network np project k = do
     stakePoolsSummary :: BF.ClientConfig -> Coin -> IO StakePoolsSummary
     stakePoolsSummary bfConfig _coin = do
         protocolParameters <- currentProtocolParameters bfConfig
-        runBFM bfConfig do
+        BFM.run bfConfig do
             BF.Network{_networkStake = BF.NetworkStake{_stakeLive}} <-
                 BF.getNetworkInfo
             totalLiveStake <- fromBlockfrostM _stakeLive
@@ -1174,40 +1139,3 @@ getPoolPerformanceEstimate sp dl rp pid = do
                     / fromIntegral (unCoin $ totalStake rp)
                     -- _poolHistoryActiveSize would be incorrect here
             }
-
-newtype BFM a = BFM (ReaderT BF.ClientConfig (ExceptT BlockfrostError IO) a)
-    deriving newtype
-        ( Functor
-        , Applicative
-        , Monad
-        , MonadIO
-        , MonadBase IO
-        , MonadBaseControl IO
-        , MonadReader BF.ClientConfig
-        , MonadError BlockfrostError
-        )
-
-instance BF.MonadBlockfrost BFM where
-    getConf = ask
-    liftBlockfrostClient act = BFM do
-        env <- asks fst
-        liftIO (runClientM act env) >>= either (throwError . ClientError) pure
-
-newClientConfig :: BF.Project -> IO BF.ClientConfig
-newClientConfig prj = (,prj) <$> BF.newEnvByProject prj
-
-runBFM :: BF.ClientConfig -> BFM a -> IO a
-runBFM cfg (BFM c) = handleBlockfrostError (runReaderT c cfg)
-
-handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a
-handleBlockfrostError =
-    either (throwIO . BlockfrostException) pure <=< runExceptT
-
-maybe404 :: BFM a -> BFM (Maybe a)
-maybe404 bfm = (Just <$> bfm) `catchError` \case
-    ClientError (Servant.FailureResponse _ (Servant.Response s _ _ _))
-        | s == status404 -> pure Nothing
-    e -> throwError e
-
-empty404 :: Monoid a => BFM a -> BFM a
-empty404 = (fromMaybe mempty <$>) . maybe404
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
new file mode 100644
index 00000000000..5cac96f77b0
--- /dev/null
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
@@ -0,0 +1,41 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+
+module Cardano.Wallet.Shelley.Network.Blockfrost.Error where
+
+import Prelude
+
+import Cardano.Wallet.Primitive.Types
+    ( EpochNo )
+import Cardano.Wallet.Primitive.Types.Coin
+    ( Coin )
+import Control.Exception
+    ( Exception )
+import Data.Text
+    ( Text )
+import Data.Text.Class
+    ( TextDecodingError )
+
+import qualified Blockfrost.Client as BF
+import qualified Servant.Client as Servant
+
+data BlockfrostError
+    = ClientError Servant.ClientError
+    | NoSlotError BF.Block
+    | IntegralCastError String
+    | InvalidBlockHash BF.BlockHash TextDecodingError
+    | InvalidTxMetadataLabel String
+    | InvalidTxMetadataValue String
+    | InvalidTxHash Text TextDecodingError
+    | InvalidAddress Text TextDecodingError
+    | InvalidPoolId Text TextDecodingError
+    | PoolStakePercentageError Coin Coin
+    | InvalidDecentralizationLevelPercentage Double
+    | InvalidUtxoInputAmount BF.UtxoInput
+    | InvalidUtxoOutputAmount BF.UtxoOutput
+    | UnknownEraForEpoch EpochNo
+    deriving (Show, Eq)
+
+newtype BlockfrostException = BlockfrostException BlockfrostError
+    deriving stock (Show)
+    deriving anyclass (Exception)
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
new file mode 100644
index 00000000000..324eb06333c
--- /dev/null
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Cardano.Wallet.Shelley.Network.Blockfrost.Monad where
+
+import Prelude
+
+import Cardano.Wallet.Shelley.Network.Blockfrost.Error
+    ( BlockfrostError (ClientError)
+    , BlockfrostException (BlockfrostException)
+    )
+import Control.Exception
+    ( throwIO )
+import Control.Monad.Base
+    ( MonadBase )
+import Control.Monad.Except
+    ( ExceptT, MonadError (..), MonadIO (..), runExceptT, (<=<) )
+import Control.Monad.Reader
+    ( MonadReader (ask), ReaderT (..), asks )
+import Control.Monad.Trans.Control
+    ( MonadBaseControl )
+import Data.Maybe
+    ( fromMaybe )
+import Network.HTTP.Types
+    ( status404 )
+import Servant.Client
+    ( runClientM )
+
+import qualified Blockfrost.Client as BF
+import qualified Servant.Client as Servant
+
+newtype BFM a = BFM (ReaderT BF.ClientConfig (ExceptT BlockfrostError IO) a)
+    deriving newtype
+        ( Functor
+        , Applicative
+        , Monad
+        , MonadIO
+        , MonadBase IO
+        , MonadBaseControl IO
+        , MonadReader BF.ClientConfig
+        , MonadError BlockfrostError
+        )
+
+instance BF.MonadBlockfrost BFM where
+    getConf = ask
+    liftBlockfrostClient act = BFM do
+        env <- asks fst
+        liftIO (runClientM act env) >>= either (throwError . ClientError) pure
+
+newClientConfig :: BF.Project -> IO BF.ClientConfig
+newClientConfig prj = (,prj) <$> BF.newEnvByProject prj
+
+run :: BF.ClientConfig -> BFM a -> IO a
+run cfg (BFM c) = handleBlockfrostError (runReaderT c cfg)
+
+handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a
+handleBlockfrostError =
+    either (throwIO . BlockfrostException) pure <=< runExceptT
+
+maybe404 :: BFM a -> BFM (Maybe a)
+maybe404 bfm = (Just <$> bfm) `catchError` \case
+    ClientError (Servant.FailureResponse _ (Servant.Response s _ _ _))
+        | s == status404 -> pure Nothing
+    e -> throwError e
+
+empty404 :: Monoid a => BFM a -> BFM a
+empty404 = (fromMaybe mempty <$>) . maybe404

From 08e411caf9176d80cd06d71993953250a258b70d Mon Sep 17 00:00:00 2001
From: IOHK <devops+stack-project@iohk.io>
Date: Thu, 9 Jun 2022 09:35:03 +0000
Subject: [PATCH 4/6] Regenerate nix

---
 .../Shelley/Network/Blockfrost/Conversion.hs  | 72 +++++++++++++++
 .../Shelley/Network/Blockfrost/Error.hs       |  1 +
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 90 +++++++++++++++++++
 nix/materialized/stack-nix/cardano-wallet.nix |  3 +
 4 files changed, 166 insertions(+)
 create mode 100644 lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs
new file mode 100644
index 00000000000..b8b1db65369
--- /dev/null
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Conversion.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Wallet.Shelley.Network.Blockfrost.Conversion where
+
+import Prelude
+
+import Cardano.Wallet.Api.Types
+    ( decodeAddress, decodeStakeAddress )
+import Cardano.Wallet.Primitive.AddressDerivation
+    ( RewardAccount )
+import Cardano.Wallet.Primitive.Types
+    ( StakePoolMetadataHash )
+import Cardano.Wallet.Primitive.Types.Coin
+    ( Coin (Coin) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Error
+    ( BlockfrostError (..), (<?#>) )
+import Cardano.Wallet.Shelley.Network.Discriminant
+    ( SomeNetworkDiscriminant (..) )
+import Control.Monad.Error.Class
+    ( MonadError (throwError) )
+import Data.IntCast
+    ( intCast )
+import Data.Proxy
+    ( Proxy (..) )
+import Data.Quantity
+    ( Percentage, mkPercentage )
+import Data.Text
+    ( Text )
+import Data.Text.Class
+    ( fromText )
+
+import qualified Blockfrost.Client as BF
+import Cardano.Wallet.Primitive.Types.Address
+    ( Address )
+
+fromBfLovelaces :: MonadError BlockfrostError m => BF.Lovelaces -> m Coin
+fromBfLovelaces lovs = Coin <$> (intCast @_ @Integer lovs <?#> "Lovelaces")
+
+fromBfAddress
+    :: MonadError BlockfrostError m
+    => SomeNetworkDiscriminant
+    -> BF.Address
+    -> m Address
+fromBfAddress (SomeNetworkDiscriminant (Proxy :: Proxy nd)) (BF.Address addr) =
+    case decodeAddress @nd addr of
+        Left e -> throwError (InvalidAddress addr e)
+        Right a -> pure a
+
+fromBfStakeAddress
+    :: MonadError BlockfrostError m
+    => SomeNetworkDiscriminant
+    -> BF.Address
+    -> m RewardAccount
+fromBfStakeAddress (SomeNetworkDiscriminant (Proxy :: Proxy nd)) (BF.Address addr) =
+    case decodeStakeAddress @nd addr of
+        Left e -> throwError (InvalidStakeAddress addr e)
+        Right a -> pure a
+
+percentageFromDouble :: MonadError BlockfrostError m => Double -> m Percentage
+percentageFromDouble d =
+    case mkPercentage (toRational d) of
+        Left e -> throwError (InvalidPercentage d e)
+        Right a -> pure a
+
+stakePoolMetadataHashFromText
+    :: MonadError BlockfrostError m => Text -> m StakePoolMetadataHash
+stakePoolMetadataHashFromText text =
+    case fromText text of
+        Left e -> throwError (InvalidStakePoolMetadataHash text e)
+        Right a -> pure a
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
index 5cac96f77b0..34b84c11cb4 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
@@ -28,6 +28,7 @@ data BlockfrostError
     | InvalidTxMetadataValue String
     | InvalidTxHash Text TextDecodingError
     | InvalidAddress Text TextDecodingError
+    | InvalidStakeAddress Text TextDecodingError
     | InvalidPoolId Text TextDecodingError
     | PoolStakePercentageError Coin Coin
     | InvalidDecentralizationLevelPercentage Double
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 96160687ec6..96ea0747665 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -31,6 +31,9 @@ module Cardano.Wallet.Shelley.Pools
 
     -- * Logs
     , StakePoolLog (..)
+
+    -- * Internal, for testing:
+    , _getPoolLifeCycleStatus
     )
     where
 
@@ -63,6 +66,8 @@ import Cardano.Wallet.Byron.Compatibility
     ( toByronBlockHeader )
 import Cardano.Wallet.Network
     ( ChainFollowLog (..), ChainFollower (..), NetworkLayer (..) )
+import Cardano.Wallet.Primitive.AddressDerivation
+    ( unRewardAccount )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
@@ -110,6 +115,18 @@ import Cardano.Wallet.Shelley.Compatibility
     , getProducer
     , toShelleyBlockHeader
     )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
+    ( fromBfLovelaces
+    , fromBfStakeAddress
+    , percentageFromDouble
+    , stakePoolMetadataHashFromText
+    )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Error
+    ( BlockfrostError (..) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Monad
+    ( BFM )
+import Cardano.Wallet.Shelley.Network.Discriminant
+    ( SomeNetworkDiscriminant (..) )
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
 import Control.Monad
@@ -286,6 +303,79 @@ withBlockfrostStakePoolLayer _tr _project =
         , getGCMetadataStatus = pure NotApplicable
         }
 
+_getPoolLifeCycleStatus
+    :: BF.ClientConfig
+    -> SomeNetworkDiscriminant
+    -> PoolId
+    -> IO PoolLifeCycleStatus
+_getPoolLifeCycleStatus
+    cfg network@(SomeNetworkDiscriminant (Proxy :: Proxy nd)) poolId =
+        BFM.run cfg do
+        let bfPoolId = BF.PoolId (toText poolId)
+        poolUpdates <- BF.getPoolUpdates bfPoolId
+        case reverse poolUpdates of
+            [] -> pure PoolNotRegistered
+            lastUpdate : otherUpdates ->
+                case BF._poolUpdateAction lastUpdate of
+                    BF.PoolRegistered ->
+                        PoolRegistered <$> poolRegCert lastUpdate
+                    BF.PoolDeregistered ->
+                        case findRegCert otherUpdates of
+                            Just regCertUpdate -> do
+                                reg <- poolRegCert regCertUpdate
+                                drg <- poolDeregCert lastUpdate
+                                pure $ PoolRegisteredAndRetired reg drg
+                            Nothing ->
+                                throwError $ PoolRegistrationIsMissing poolId
+
+    where
+    findRegCert :: [BF.PoolUpdate] -> Maybe BF.PoolUpdate
+    findRegCert = find \BF.PoolUpdate{..} ->
+        _poolUpdateAction == BF.PoolRegistered
+
+    poolRegCert :: BF.PoolUpdate -> BFM PoolRegistrationCertificate
+    poolRegCert update@BF.PoolUpdate{..} = do
+        let byIdx tpu = BF._transactionPoolUpdateCertIndex tpu
+                == _poolUpdateCertIndex
+        poolUpdates <- BF.getTxPoolUpdates _poolUpdateTxHash
+        case find byIdx poolUpdates of
+            Just BF.TransactionPoolUpdate{..} -> do
+                poolOwners <- for _transactionPoolUpdateOwners do
+                    (PoolOwner . unRewardAccount <$>) . fromBfStakeAddress network
+                poolMargin <-
+                    percentageFromDouble _transactionPoolUpdateMarginCost
+                poolCost <-
+                    fromBfLovelaces _transactionPoolUpdateFixedCost
+                poolPledge <-
+                    fromBfLovelaces _transactionPoolUpdatePledge
+                poolMetadata <-
+                    join <$> for _transactionPoolUpdateMetadata
+                        \BF.PoolUpdateMetadata{..} -> runMaybeT do
+                            url <- MaybeT . pure $
+                                StakePoolMetadataUrl <$> _poolUpdateMetadataUrl
+                            hash <- MaybeT do
+                                for _poolUpdateMetadataHash
+                                    stakePoolMetadataHashFromText
+                            pure (url, hash)
+                pure PoolRegistrationCertificate{..}
+            Nothing ->
+                throwError $ PoolUpdateCertificateNotFound poolId update
+
+    poolDeregCert :: BF.PoolUpdate -> BFM PoolRetirementCertificate
+    poolDeregCert update@BF.PoolUpdate{..} = do
+        poolRetiring  <-
+            BF.getTxPoolRetiring _poolUpdateTxHash <&> find \r ->
+                _transactionPoolRetiringCertIndex r == _poolUpdateCertIndex
+        case poolRetiring of
+            Just BF.TransactionPoolRetiring{..} -> do
+                pure PoolRetirementCertificate
+                    { poolId
+                    , retirementEpoch =
+                        fromIntegral _transactionPoolRetiringRetiringEpoch
+                    }
+            Nothing ->
+                throwError $ PoolRetirementCertificateNotFound poolId update
+
 newStakePoolLayer
     :: forall sc. ()
     => TVar PoolMetadataGCStatus
diff --git a/nix/materialized/stack-nix/cardano-wallet.nix b/nix/materialized/stack-nix/cardano-wallet.nix
index 1e0f95a32b7..0527e82870e 100644
--- a/nix/materialized/stack-nix/cardano-wallet.nix
+++ b/nix/materialized/stack-nix/cardano-wallet.nix
@@ -124,7 +124,10 @@
           "Cardano/Wallet/Shelley/Compatibility/Ledger"
           "Cardano/Wallet/Shelley/Network"
           "Cardano/Wallet/Shelley/Network/Blockfrost"
+          "Cardano/Wallet/Shelley/Network/Blockfrost/Conversion"
+          "Cardano/Wallet/Shelley/Network/Blockfrost/Error"
           "Cardano/Wallet/Shelley/Network/Blockfrost/Fixture"
+          "Cardano/Wallet/Shelley/Network/Blockfrost/Monad"
           "Cardano/Wallet/Shelley/Network/Discriminant"
           "Cardano/Wallet/Shelley/Network/Node"
           "Cardano/Wallet/Shelley/Transaction"

From 645593b4bb5e87aff6f43d81acc5f4dcc12af0e0 Mon Sep 17 00:00:00 2001
From: Yuriy Lazaryev <yuriy.lazaryev@iohk.io>
Date: Thu, 9 Jun 2022 17:37:43 +0200
Subject: [PATCH 5/6] Implement getPoolLifeCycleStatus

---
 lib/shelley/cardano-wallet.cabal              |   1 +
 lib/shelley/src/Cardano/Wallet/Shelley.hs     |   2 +-
 .../Wallet/Shelley/Network/Blockfrost.hs      |  76 ++++--------
 .../Shelley/Network/Blockfrost/Error.hs       |  37 +++++-
 .../Shelley/Network/Blockfrost/Monad.hs       |   3 +-
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 112 +++++++++++++++---
 6 files changed, 160 insertions(+), 71 deletions(-)

diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal
index c8e8437409b..bf5b9068774 100644
--- a/lib/shelley/cardano-wallet.cabal
+++ b/lib/shelley/cardano-wallet.cabal
@@ -120,6 +120,7 @@ library
       Cardano.Wallet.Shelley.Compatibility.Ledger
       Cardano.Wallet.Shelley.Network
       Cardano.Wallet.Shelley.Network.Blockfrost
+      Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
       Cardano.Wallet.Shelley.Network.Blockfrost.Error
       Cardano.Wallet.Shelley.Network.Blockfrost.Fixture
       Cardano.Wallet.Shelley.Network.Blockfrost.Monad
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index 80613e21351..4cdda5a49c4 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -250,7 +250,7 @@ serveWallet
                 netParams
                 netLayer
         BlockfrostSource bfProject -> do
-            withBlockfrostStakePoolLayer poolsEngineTracer bfProject
+            withBlockfrostStakePoolLayer poolsEngineTracer bfProject network
     randomApi <- withRandomApi netLayer
     icarusApi  <- withIcarusApi netLayer
     shelleyApi <- withShelleyApi netLayer
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
index d0536cb0e07..de535d73808 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
@@ -22,13 +22,13 @@
 --
 -- Network Layer implementation that uses Blockfrost API
 module Cardano.Wallet.Shelley.Network.Blockfrost
-  ( withNetworkLayer,
-    Log,
+    ( withNetworkLayer,
+        Log,
 
-    -- * Internal
-    getPoolPerformanceEstimate,
-    eraByEpoch
-  )
+        -- * Internal
+        getPoolPerformanceEstimate,
+        eraByEpoch
+    )
 where
 
 import Prelude
@@ -58,7 +58,7 @@ import Cardano.Pool.Rank.Likelihood
 import Cardano.Slotting.Slot
     ( unEpochSize )
 import Cardano.Wallet.Api.Types
-    ( decodeAddress, decodeStakeAddress, encodeAddress, encodeStakeAddress )
+    ( decodeStakeAddress, encodeAddress, encodeStakeAddress )
 import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer )
 import Cardano.Wallet.Network
@@ -132,8 +132,10 @@ import Cardano.Wallet.Primitive.Types.TokenBundle
     ( TokenBundle (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Tx (..), TxIn (..), TxOut (..), TxScriptValidity (..), TxSize (..) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
+    ( fromBfAddress, fromBfLovelaces )
 import Cardano.Wallet.Shelley.Network.Blockfrost.Error
-    ( BlockfrostError (..) )
+    ( BlockfrostError (..), (<?#>), (<?>) )
 import Cardano.Wallet.Shelley.Network.Blockfrost.Monad
     ( BFM )
 import Cardano.Wallet.Shelley.Network.Discriminant
@@ -158,8 +160,6 @@ import Data.Bifunctor
     ( first )
 import Data.Bitraversable
     ( bitraverse )
-import Data.Bits
-    ( Bits )
 import Data.Function
     ( (&) )
 import Data.Functor
@@ -167,7 +167,7 @@ import Data.Functor
 import Data.Functor.Contravariant
     ( (>$<) )
 import Data.IntCast
-    ( intCast, intCastMaybe )
+    ( intCast )
 import Data.List
     ( partition )
 import Data.List.NonEmpty
@@ -203,8 +203,6 @@ import Fmt
     ( pretty )
 import GHC.OldList
     ( sortOn )
-import Money
-    ( Discrete' )
 import Ouroboros.Consensus.Cardano.Block
     ( CardanoBlock, StandardCrypto )
 import Ouroboros.Consensus.HardFork.History.EraParams
@@ -649,7 +647,7 @@ withNetworkLayer tr network np project k = do
         BFM.run bfConfig do
             BF.Network{_networkStake = BF.NetworkStake{_stakeLive}} <-
                 BF.getNetworkInfo
-            totalLiveStake <- fromBlockfrostM _stakeLive
+            totalLiveStake <- fromBfLovelaces _stakeLive
             pools <- mapConcurrently BF.getPool =<< BF.listPools
             stake <- poolsStake totalLiveStake pools
             pure StakePoolsSummary
@@ -667,12 +665,12 @@ withNetworkLayer tr network np project k = do
                 -> m (Map PoolId Percentage)
             poolsStake total = fmap Map.fromList . traverse \BF.PoolInfo{..} ->
                 (,) <$> fromBlockfrostM _poolInfoPoolId <*> do
-                    live <- fromBlockfrostM @_ @Coin _poolInfoLiveStake
+                    live <- fromBfLovelaces _poolInfoLiveStake
                     let ratio = Coin.toInteger live % Coin.toInteger total
                     case mkPercentage ratio of
-                       Right percentage -> pure percentage
-                       Left PercentageOutOfBoundsError ->
-                           throwError $ PoolStakePercentageError total live
+                        Right percentage -> pure percentage
+                        Left PercentageOutOfBoundsError ->
+                            throwError $ PoolStakePercentageError total live
 
 fetchNextBlocks
     :: forall m
@@ -781,7 +779,7 @@ assembleTransaction
     -> [BF.TransactionMetaJSON]
     -> m Tx
 assembleTransaction
-    (SomeNetworkDiscriminant (Proxy :: Proxy nd))
+    network@(SomeNetworkDiscriminant (Proxy :: Proxy nd))
     BF.Transaction{..}
     BF.TransactionUtxos{..}
     txWithdrawals
@@ -791,15 +789,12 @@ assembleTransaction
         (resolvedInputs, resolvedCollateralInputs) <-
             fromInputs _transactionUtxosInputs
         outputs <- for _transactionUtxosOutputs \out@BF.UtxoOutput{..} -> do
-            let outAddr = BF.unAddress _utxoOutputAddress
-            address <-
-                either (throwError . InvalidAddress outAddr) pure $
-                    decodeAddress @nd outAddr
+            address <- fromBfAddress network _utxoOutputAddress
             tokens <- do
                 coin <- case [ lovelaces
                              | BF.AdaAmount lovelaces <- _utxoOutputAmount
                              ] of
-                    [l] -> fromBlockfrost l
+                    [l] -> fromBfLovelaces l
                     _ -> throwError $ InvalidUtxoOutputAmount out
                 pure $ TokenBundle coin mempty -- TODO: Handle native assets
             pure TxOut{..}
@@ -809,7 +804,7 @@ assembleTransaction
                     let addr = BF.unAddress _transactionWithdrawalAddress
                     rewardAccount <-
                         first (InvalidAddress addr) $ decodeStakeAddress @nd addr
-                    coin <- fromBlockfrost _transactionWithdrawalAmount
+                    coin <- fromBfLovelaces _transactionWithdrawalAmount
                     pure (rewardAccount, coin)
         metadata <-
             if null metadataJSON
@@ -851,7 +846,7 @@ assembleTransaction
                 txIndex <- _utxoInputOutputIndex <?#> "_utxoInputOutputIndex"
                 coin <-
                     case [lovelaces | BF.AdaAmount lovelaces <- _utxoInputAmount] of
-                        [l] -> fromBlockfrost l
+                        [l] -> fromBfLovelaces l
                         _ -> throwError $ InvalidUtxoInputAmount input
                 pure (TxIn txHash txIndex, coin)
 
@@ -905,8 +900,7 @@ fromBlockfrostPP
 fromBlockfrostPP network BF.ProtocolParams{..} = do
     decentralizationLevel <-
         let percentage =
-                mkPercentage $
-                    toRational _protocolParamsDecentralisationParam
+                mkPercentage $ toRational _protocolParamsDecentralisationParam
             in case percentage of
                 Left PercentageOutOfBoundsError ->
                     throwError $
@@ -1064,11 +1058,6 @@ instance FromBlockfrost BF.PoolId PoolId where
 instance FromBlockfrost BF.Epoch EpochNo where
     fromBlockfrost = pure . fromIntegral
 
--- type Lovelaces = Discrete' "ADA" '(1000000, 1)
-instance FromBlockfrost (Discrete' "ADA" '(1000000, 1)) Coin where
-    fromBlockfrost lovelaces =
-        Coin <$> (intCast @_ @Integer lovelaces <?#> "Lovelaces")
-
 eraByEpoch :: NetworkId -> EpochNo -> Either BlockfrostError AnyCardanoEra
 eraByEpoch networkId epoch =
     dropWhile ((> epoch) . snd) (reverse (Fixture.eraBoundaries networkId)) &
@@ -1087,27 +1076,6 @@ epochEraSummary networkId (EpochNo epoch) =
         UC.NonEmptyCons era@EraSummary{eraEnd=EraEnd Bound{boundEpoch}} eras ->
             if boundEpoch > fromIntegral epoch then era else go eras
 
--- | Raises an error in case of an absent value
-(<?>) :: MonadError e m => Maybe a -> e -> m a
-(<?>) Nothing e = throwError e
-(<?>) (Just a) _ = pure a
-
-infixl 8 <?>
-
-{-# INLINE (<?>) #-}
-
--- | Casts integral values safely or raises an `IntegralCastError`
-(<?#>)
-    :: (MonadError BlockfrostError m, Integral a, Integral b, Bits a, Bits b)
-    => a
-    -> String
-    -> m b
-(<?#>) a e = intCastMaybe a <?> IntegralCastError e
-
-infixl 8 <?#>
-
-{-# INLINE (<?#>) #-}
-
 {-------------------------------------------------------------------------------
     Stake Pools
 -------------------------------------------------------------------------------}
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
index 34b84c11cb4..384086d7374 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
@@ -1,22 +1,31 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Cardano.Wallet.Shelley.Network.Blockfrost.Error where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Types
-    ( EpochNo )
+    ( EpochNo, PoolId )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin )
 import Control.Exception
     ( Exception )
+import Data.Bits
+    ( Bits )
 import Data.Text
     ( Text )
 import Data.Text.Class
     ( TextDecodingError )
 
 import qualified Blockfrost.Client as BF
+import Control.Monad.Error.Class
+    ( MonadError (throwError) )
+import Data.IntCast
+    ( intCastMaybe )
+import Data.Quantity
+    ( MkPercentageError )
 import qualified Servant.Client as Servant
 
 data BlockfrostError
@@ -26,12 +35,17 @@ data BlockfrostError
     | InvalidBlockHash BF.BlockHash TextDecodingError
     | InvalidTxMetadataLabel String
     | InvalidTxMetadataValue String
+    | InvalidStakePoolMetadataHash Text TextDecodingError
+    | PoolRegistrationIsMissing PoolId
+    | PoolRetirementCertificateNotFound PoolId BF.PoolUpdate
+    | PoolUpdateCertificateNotFound PoolId BF.PoolUpdate
     | InvalidTxHash Text TextDecodingError
     | InvalidAddress Text TextDecodingError
     | InvalidStakeAddress Text TextDecodingError
     | InvalidPoolId Text TextDecodingError
     | PoolStakePercentageError Coin Coin
     | InvalidDecentralizationLevelPercentage Double
+    | InvalidPercentage Double MkPercentageError
     | InvalidUtxoInputAmount BF.UtxoInput
     | InvalidUtxoOutputAmount BF.UtxoOutput
     | UnknownEraForEpoch EpochNo
@@ -40,3 +54,24 @@ data BlockfrostError
 newtype BlockfrostException = BlockfrostException BlockfrostError
     deriving stock (Show)
     deriving anyclass (Exception)
+
+-- | Raises an error in case of an absent value
+(<?>) :: MonadError e m => Maybe a -> e -> m a
+(<?>) Nothing e = throwError e
+(<?>) (Just a) _ = pure a
+
+infixl 8 <?>
+
+{-# INLINE (<?>) #-}
+
+-- | Casts integral values safely or raises an `IntegralCastError`
+(<?#>)
+    :: (MonadError BlockfrostError m, Integral a, Integral b, Bits a, Bits b)
+    => a
+    -> String
+    -> m b
+(<?#>) a e = intCastMaybe a <?> IntegralCastError e
+
+infixl 8 <?#>
+
+{-# INLINE (<?#>) #-}
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
index 324eb06333c..de55301db17 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -54,7 +55,7 @@ instance BF.MonadBlockfrost BFM where
 newClientConfig :: BF.Project -> IO BF.ClientConfig
 newClientConfig prj = (,prj) <$> BF.newEnvByProject prj
 
-run :: BF.ClientConfig -> BFM a -> IO a
+run :: BF.ClientConfig -> (forall a. BFM a -> IO a)
 run cfg (BFM c) = handleBlockfrostError (runReaderT c cfg)
 
 handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 96ea0747665..8911301db13 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -39,6 +39,8 @@ module Cardano.Wallet.Shelley.Pools
 
 import Prelude
 
+import Blockfrost.Client
+    ( TransactionPoolRetiring (_transactionPoolRetiringCertIndex) )
 import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
@@ -89,6 +91,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolLifeCycleStatus (..)
     , PoolMetadataGCStatus (..)
     , PoolMetadataSource (..)
+    , PoolOwner (PoolOwner)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
     , Settings (..)
@@ -97,7 +100,9 @@ import Cardano.Wallet.Primitive.Types
     , SlottingParameters (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
+    , StakePoolMetadataUrl (StakePoolMetadataUrl)
     , StakePoolsSummary (..)
+    , encodePoolIdBech32
     , getPoolRegistrationCertificate
     , getPoolRetirementCertificate
     , unSmashServer
@@ -130,15 +135,19 @@ import Cardano.Wallet.Shelley.Network.Discriminant
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
 import Control.Monad
-    ( forM, forM_, forever, void, when, (>=>) )
+    ( forM, forM_, forever, join, void, when, (>=>) )
 import Control.Monad.Cont
     ( ContT (ContT) )
+import Control.Monad.Error.Class
+    ( throwError )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT (..), runExceptT )
+import Control.Monad.Trans.Maybe
+    ( MaybeT (MaybeT), runMaybeT )
 import Control.Monad.Trans.State
     ( State, evalState, state )
 import Control.Retry
@@ -147,8 +156,12 @@ import Control.Tracer
     ( Tracer, contramap, traceWith )
 import Data.Bifunctor
     ( first )
+import Data.Foldable
+    ( find )
 import Data.Function
     ( (&) )
+import Data.Functor
+    ( (<&>) )
 import Data.Generics.Internal.VL.Lens
     ( view )
 import Data.List
@@ -163,6 +176,8 @@ import Data.Maybe
     ( fromMaybe, mapMaybe )
 import Data.Ord
     ( Down (..) )
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Quantity
     ( Percentage (..), Quantity (..) )
 import Data.Set
@@ -171,6 +186,8 @@ import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock.POSIX
     ( getPOSIXTime, posixDayLength )
+import Data.Traversable
+    ( for )
 import Data.Tuple.Extra
     ( dupe )
 import Data.Void
@@ -210,6 +227,7 @@ import qualified Blockfrost.Client as BF
 import qualified Cardano.Pool.DB as PoolDb
 import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Types as Api
+import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Monad as BFM
 import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Merge.Strict as Map
@@ -217,17 +235,11 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified UnliftIO.STM as STM
 
---
--- Stake Pool Layer
---
 
 data StakePoolLayer = StakePoolLayer
-    { getPoolLifeCycleStatus
-        :: PoolId
-        -> IO PoolLifeCycleStatus
+    { getPoolLifeCycleStatus :: PoolId -> IO PoolLifeCycleStatus
 
-    , knownPools
-        :: IO (Set PoolId)
+    , knownPools :: IO (Set 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
@@ -237,8 +249,7 @@ data StakePoolLayer = StakePoolLayer
     -- epoch will be excluded from the result.
     --
     , listStakePools
-        :: EpochNo
-        -- Exclude all pools that retired in or before this epoch.
+        :: EpochNo -- Exclude all pools that retired in or before this epoch.
         -> Coin
         -> IO [Api.ApiStakePool]
 
@@ -291,10 +302,12 @@ withStakePoolDbLayer poolDbTracer databaseDir poolDbDecorator netLayer =
 withBlockfrostStakePoolLayer
     :: Tracer IO StakePoolLog
     -> BF.Project
+    -> SomeNetworkDiscriminant
     -> ContT r IO StakePoolLayer
-withBlockfrostStakePoolLayer _tr _project =
+withBlockfrostStakePoolLayer _tr project network = do
+    bfConfig <- lift (BFM.newClientConfig project)
     ContT \k -> k StakePoolLayer
-        { getPoolLifeCycleStatus = \_poolId -> pure PoolNotRegistered
+        { getPoolLifeCycleStatus = _getPoolLifeCycleStatus bfConfig network
         , knownPools = pure Set.empty
         , listStakePools = \_epochNo _coin -> pure []
         , forceMetadataGC = pure ()
@@ -302,6 +315,77 @@ withBlockfrostStakePoolLayer _tr _project =
         , getSettings = pure $ Settings FetchNone
         , getGCMetadataStatus = pure NotApplicable
         }
+  where
+    _getPoolLifeCycleStatus
+        :: BF.ClientConfig
+        -> SomeNetworkDiscriminant
+        -> PoolId
+        -> IO PoolLifeCycleStatus
+    _getPoolLifeCycleStatus
+        cfg (SomeNetworkDiscriminant (Proxy :: Proxy nd)) poolId = BFM.run cfg do
+        let bfPoolId = BF.PoolId (encodePoolIdBech32 poolId)
+        poolUpdates <- BF.getPoolUpdates bfPoolId
+        case reverse poolUpdates of
+            [] -> pure PoolNotRegistered
+            lastUpdate : otherUpdates ->
+                case BF._poolUpdateAction lastUpdate of
+                    BF.PoolRegistered -> PoolRegistered <$> poolRegCert lastUpdate
+                    BF.PoolDeregistered ->
+                        case findRegCert otherUpdates of
+                            Just regCertUpdate -> do
+                                reg <- poolRegCert regCertUpdate
+                                drg <- poolDeregCert lastUpdate
+                                pure $ PoolRegisteredAndRetired reg drg
+                            Nothing ->
+                                throwError $ PoolRegistrationIsMissing poolId
+
+      where
+        findRegCert :: [BF.PoolUpdate] -> Maybe BF.PoolUpdate
+        findRegCert = find \BF.PoolUpdate{..} ->
+            _poolUpdateAction == BF.PoolRegistered
+
+        poolRegCert :: BF.PoolUpdate -> BFM PoolRegistrationCertificate
+        poolRegCert update@BF.PoolUpdate{..} = do
+            let byIdx tpu = BF._transactionPoolUpdateCertIndex tpu
+                    == _poolUpdateCertIndex
+            poolUpdates <- BF.getTxPoolUpdates _poolUpdateTxHash
+            case find byIdx poolUpdates of
+                Just BF.TransactionPoolUpdate{..} -> do
+                    poolOwners <- for _transactionPoolUpdateOwners do
+                        (PoolOwner . unRewardAccount <$>) . fromBfStakeAddress network
+                    poolMargin <-
+                        percentageFromDouble _transactionPoolUpdateMarginCost
+                    poolCost <-
+                        fromBfLovelaces _transactionPoolUpdateFixedCost
+                    poolPledge <-
+                        fromBfLovelaces _transactionPoolUpdatePledge
+                    poolMetadata <-
+                        join <$> for _transactionPoolUpdateMetadata
+                            \BF.PoolUpdateMetadata{..} -> runMaybeT do
+                                url <- MaybeT . pure $
+                                    StakePoolMetadataUrl <$> _poolUpdateMetadataUrl
+                                hash <- MaybeT do
+                                    for _poolUpdateMetadataHash
+                                        stakePoolMetadataHashFromText
+                                pure (url, hash)
+                    pure PoolRegistrationCertificate{..}
+                Nothing ->
+                    throwError $ PoolUpdateCertificateNotFound poolId update
+
+        poolDeregCert :: BF.PoolUpdate -> BFM PoolRetirementCertificate
+        poolDeregCert update@BF.PoolUpdate{..} = do
+            poolRetiring  <-
+                BF.getTxPoolRetiring _poolUpdateTxHash <&> find \r ->
+                    _transactionPoolRetiringCertIndex r == _poolUpdateCertIndex
+            case poolRetiring of
+                Just BF.TransactionPoolRetiring{..} -> do
+                    pure PoolRetirementCertificate
+                        { poolId
+                        , retirementEpoch =
+                            fromIntegral _transactionPoolRetiringRetiringEpoch
+                        }
+                Nothing ->
+                    throwError $ PoolRetirementCertificateNotFound poolId update
 
 _getPoolLifeCycleStatus
     :: BF.ClientConfig
@@ -383,7 +467,7 @@ newStakePoolLayer
     -> DBLayer IO
     -> IO ()
     -> IO StakePoolLayer
-newStakePoolLayer gcStatus nl db@DBLayer {..} restartSyncThread =
+newStakePoolLayer gcStatus nl db@DBLayer{..} restartSyncThread =
     pure StakePoolLayer
         { getPoolLifeCycleStatus = _getPoolLifeCycleStatus
         , knownPools = _knownPools

From a61918b95b284b019488c6b4054688ed2fa82d1d Mon Sep 17 00:00:00 2001
From: Yuriy Lazaryev <yuriy.lazaryev@iohk.io>
Date: Mon, 13 Jun 2022 12:45:28 +0200
Subject: [PATCH 6/6] Light Mode: known pools for the StakePoolLayer

---
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 149 ++++++------------
 1 file changed, 44 insertions(+), 105 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 8911301db13..881e29c3d1f 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -34,6 +34,7 @@ module Cardano.Wallet.Shelley.Pools
 
     -- * Internal, for testing:
     , _getPoolLifeCycleStatus
+    , _knownPools
     )
     where
 
@@ -68,8 +69,6 @@ import Cardano.Wallet.Byron.Compatibility
     ( toByronBlockHeader )
 import Cardano.Wallet.Network
     ( ChainFollowLog (..), ChainFollower (..), NetworkLayer (..) )
-import Cardano.Wallet.Primitive.AddressDerivation
-    ( unRewardAccount )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
@@ -102,13 +101,15 @@ import Cardano.Wallet.Primitive.Types
     , StakePoolMetadataHash
     , StakePoolMetadataUrl (StakePoolMetadataUrl)
     , StakePoolsSummary (..)
-    , encodePoolIdBech32
+    , decodePoolIdBech32
     , getPoolRegistrationCertificate
     , getPoolRetirementCertificate
     , unSmashServer
     )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
+import Cardano.Wallet.Primitive.Types.RewardAccount
+    ( unRewardAccount )
 import Cardano.Wallet.Registry
     ( AfterThreadLog, traceAfterThread )
 import Cardano.Wallet.Shelley.Compatibility
@@ -308,84 +309,13 @@ withBlockfrostStakePoolLayer _tr project network = do
     bfConfig <- lift (BFM.newClientConfig project)
     ContT \k -> k StakePoolLayer
         { getPoolLifeCycleStatus = _getPoolLifeCycleStatus bfConfig network
-        , knownPools = pure Set.empty
+        , knownPools = _knownPools bfConfig
         , listStakePools = \_epochNo _coin -> pure []
         , forceMetadataGC = pure ()
         , putSettings = \_settings -> pure ()
         , getSettings = pure $ Settings FetchNone
         , getGCMetadataStatus = pure NotApplicable
         }
-  where
-    _getPoolLifeCycleStatus
-        :: BF.ClientConfig
-        -> SomeNetworkDiscriminant
-        -> PoolId
-        -> IO PoolLifeCycleStatus
-    _getPoolLifeCycleStatus
-        cfg (SomeNetworkDiscriminant (Proxy :: Proxy nd)) poolId = BFM.run cfg do
-        let bfPoolId = BF.PoolId (encodePoolIdBech32 poolId)
-        poolUpdates <- BF.getPoolUpdates bfPoolId
-        case reverse poolUpdates of
-            [] -> pure PoolNotRegistered
-            lastUpdate : otherUpdates ->
-                case BF._poolUpdateAction lastUpdate of
-                    BF.PoolRegistered -> PoolRegistered <$> poolRegCert lastUpdate
-                    BF.PoolDeregistered ->
-                        case findRegCert otherUpdates of
-                            Just regCertUpdate -> do
-                                reg <- poolRegCert regCertUpdate
-                                drg <- poolDeregCert lastUpdate
-                                pure $ PoolRegisteredAndRetired reg drg
-                            Nothing ->
-                                throwError $ PoolRegistrationIsMissing poolId
-
-      where
-        findRegCert :: [BF.PoolUpdate] -> Maybe BF.PoolUpdate
-        findRegCert = find \BF.PoolUpdate{..} ->
-            _poolUpdateAction == BF.PoolRegistered
-
-        poolRegCert :: BF.PoolUpdate -> BFM PoolRegistrationCertificate
-        poolRegCert update@BF.PoolUpdate{..} = do
-            let byIdx tpu = BF._transactionPoolUpdateCertIndex tpu
-                    == _poolUpdateCertIndex
-            poolUpdates <- BF.getTxPoolUpdates _poolUpdateTxHash
-            case find byIdx poolUpdates of
-                Just BF.TransactionPoolUpdate{..} -> do
-                    poolOwners <- for _transactionPoolUpdateOwners do
-                        (PoolOwner . unRewardAccount <$>) . fromBfStakeAddress network
-                    poolMargin <-
-                        percentageFromDouble _transactionPoolUpdateMarginCost
-                    poolCost <-
-                        fromBfLovelaces _transactionPoolUpdateFixedCost
-                    poolPledge <-
-                        fromBfLovelaces _transactionPoolUpdatePledge
-                    poolMetadata <-
-                        join <$> for _transactionPoolUpdateMetadata
-                            \BF.PoolUpdateMetadata{..} -> runMaybeT do
-                                url <- MaybeT . pure $
-                                    StakePoolMetadataUrl <$> _poolUpdateMetadataUrl
-                                hash <- MaybeT do
-                                    for _poolUpdateMetadataHash
-                                        stakePoolMetadataHashFromText
-                                pure (url, hash)
-                    pure PoolRegistrationCertificate{..}
-                Nothing ->
-                    throwError $ PoolUpdateCertificateNotFound poolId update
-
-        poolDeregCert :: BF.PoolUpdate -> BFM PoolRetirementCertificate
-        poolDeregCert update@BF.PoolUpdate{..} = do
-            poolRetiring  <-
-                BF.getTxPoolRetiring _poolUpdateTxHash <&> find \r ->
-                    _transactionPoolRetiringCertIndex r == _poolUpdateCertIndex
-            case poolRetiring of
-                Just BF.TransactionPoolRetiring{..} -> do
-                    pure PoolRetirementCertificate
-                        { poolId
-                        , retirementEpoch =
-                            fromIntegral _transactionPoolRetiringRetiringEpoch
-                        }
-                Nothing ->
-                    throwError $ PoolRetirementCertificateNotFound poolId update
 
 _getPoolLifeCycleStatus
     :: BF.ClientConfig
@@ -395,27 +325,27 @@ _getPoolLifeCycleStatus
 _getPoolLifeCycleStatus
     cfg network@(SomeNetworkDiscriminant (Proxy :: Proxy nd)) poolId =
         BFM.run cfg do
-        let bfPoolId = BF.PoolId (toText poolId)
-        poolUpdates <- BF.getPoolUpdates bfPoolId
-        case reverse poolUpdates of
-            [] -> pure PoolNotRegistered
-            lastUpdate : otherUpdates ->
-                case BF._poolUpdateAction lastUpdate of
-                    BF.PoolRegistered ->
-                        PoolRegistered <$> poolRegCert lastUpdate
-                    BF.PoolDeregistered ->
-                        case findRegCert otherUpdates of
-                            Just regCertUpdate -> do
-                                reg <- poolRegCert regCertUpdate
-                                drg <- poolDeregCert lastUpdate
-                                pure $ PoolRegisteredAndRetired reg drg
-                            Nothing ->
-                                throwError $ PoolRegistrationIsMissing poolId
+            let bfPoolId = BF.PoolId (toText poolId)
+            poolUpdates <- BF.allPages \paged ->
+                BF.getPoolUpdates' bfPoolId paged BF.Descending
+            case poolUpdates of
+                [] -> pure PoolNotRegistered
+                lastUpdate : otherUpdates ->
+                    case BF._poolUpdateAction lastUpdate of
+                        BF.PoolRegistered ->
+                            PoolRegistered <$> poolRegCert lastUpdate
+                        BF.PoolDeregistered ->
+                            case findRegCert otherUpdates of
+                                Just regCertUpdate ->
+                                    PoolRegisteredAndRetired
+                                        <$> poolRegCert regCertUpdate
+                                        <*> poolDeregCert lastUpdate
+                                Nothing -> throwError $
+                                    PoolRegistrationIsMissing poolId
 
-    where
+  where
     findRegCert :: [BF.PoolUpdate] -> Maybe BF.PoolUpdate
-    findRegCert = find \BF.PoolUpdate{..} ->
-        _poolUpdateAction == BF.PoolRegistered
+    findRegCert = find \upd -> BF._poolUpdateAction upd == BF.PoolRegistered
 
     poolRegCert :: BF.PoolUpdate -> BFM PoolRegistrationCertificate
     poolRegCert update@BF.PoolUpdate{..} = do
@@ -447,7 +377,7 @@ _getPoolLifeCycleStatus
 
     poolDeregCert :: BF.PoolUpdate -> BFM PoolRetirementCertificate
     poolDeregCert update@BF.PoolUpdate{..} = do
-        poolRetiring  <-
+        poolRetiring <-
             BF.getTxPoolRetiring _poolUpdateTxHash <&> find \r ->
                 _transactionPoolRetiringCertIndex r == _poolUpdateCertIndex
         case poolRetiring of
@@ -460,6 +390,13 @@ _getPoolLifeCycleStatus
             Nothing ->
                 throwError $ PoolRetirementCertificateNotFound poolId update
 
+_knownPools :: BF.ClientConfig -> IO (Set PoolId)
+_knownPools bfConfig = Set.fromList <$> BFM.run bfConfig do
+    -- BF.listPools returns only 100 items (1 page) but we want all pages
+    BF.allPages (`BF.listPools'` BF.Ascending) >>=
+        traverse \(BF.PoolId poolId) -> decodePoolIdBech32 poolId
+            & either (throwError . InvalidPoolId poolId) pure
+
 newStakePoolLayer
     :: forall sc. ()
     => TVar PoolMetadataGCStatus
@@ -967,7 +904,8 @@ monitorMetadata gcStatus tr sp db@DBLayer{..} = do
 
         _ -> pure NoSmashConfigured
 
-    if health == Available || health == NoSmashConfigured then (do
+    if health == Available || health == NoSmashConfigured
+    then do
         case poolMetadataSource settings of
             FetchNone -> do
                 STM.atomically $ writeTVar gcStatus NotApplicable
@@ -984,7 +922,8 @@ monitorMetadata gcStatus tr sp db@DBLayer{..} = do
                     (gcDelistedPools gcStatus tr db getDelistedPools)
                     (traceAfterThread (contramap MsgGCThreadExit tr))
                 void $ fetchMetadata manager [registryUrlBuilder uri]
-                    `finally` killThread tid) else
+                    `finally` killThread tid
+    else
         traceWith tr MsgSMASHUnreachable
   where
     trFetch = contramap MsgFetchPoolMetadata tr
@@ -1003,14 +942,14 @@ monitorMetadata gcStatus tr sp db@DBLayer{..} = do
                 threadDelay blockFrequency
             forM refs $ \k@(pid, url, hash) -> k <$ withAvailableSeat inFlights (
                 fetchFromRemote trFetch strategies manager pid url hash >>= \case
-                Nothing ->
-                    atomically $ do
-                        settings' <- readSettings
-                        when (settings == settings') $ putFetchAttempt (url, hash)
-                Just meta -> do
-                    atomically $ do
-                        settings' <- readSettings
-                        when (settings == settings') $ putPoolMetadata hash meta
+                    Nothing ->
+                        atomically $ do
+                            settings' <- readSettings
+                            when (settings == settings') $ putFetchAttempt (url, hash)
+                    Just meta -> do
+                        atomically $ do
+                            settings' <- readSettings
+                            when (settings == settings') $ putPoolMetadata hash meta
                 )
       where
         -- Twice 'maxInFlight' so that, when removing keys currently in flight,