From 4536083afe9d80de612db70f1aa984e924531e4e Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Tue, 2 Jun 2020 13:34:21 +0200
Subject: [PATCH 01/14] Allow localStateQ to have multiple queries in the same
 queue

To allow both PParams, and StakeDistribution checks in the same queue.
---
 .../src/Ouroboros/Network/Client/Wallet.hs     | 18 ++++++++++--------
 1 file changed, 10 insertions(+), 8 deletions(-)

diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index 4de7e0b360c..362418b68c4 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -1,10 +1,12 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -413,8 +415,8 @@ chainSyncWithBlocks fromTip queue responseBuffer =
 -- LocalStateQuery
 
 -- | Command to send to the localStateQuery client. See also 'ChainSyncCmd'.
-data LocalStateQueryCmd block state (m :: * -> *)
-    = CmdQueryLocalState
+data LocalStateQueryCmd block (m :: * -> *)
+    = forall state. CmdQueryLocalState
         (Point block)
         (Query block state)
         (LocalStateQueryResult state -> m ())
@@ -449,8 +451,8 @@ type LocalStateQueryResult state = Either AcquireFailure state
 --                └───────────────┘             └────────────────┘
 --
 localStateQuery
-    :: forall m block state. (MonadThrow m, MonadSTM m)
-    => TQueue m (LocalStateQueryCmd block state m)
+    :: forall m block . (MonadThrow m, MonadSTM m)
+    => TQueue m (LocalStateQueryCmd block m)
         -- ^ We use a 'TQueue' as a communication channel to drive queries from
         -- outside of the network client to the client itself.
         -- Requests are pushed to the queue which are then transformed into
@@ -466,7 +468,7 @@ localStateQuery queue =
             LSQ.SendMsgAcquire pt (clientStAcquiring query respond)
 
     clientStAcquiring
-        :: Query block state
+        :: forall state. Query block state
         -> (LocalStateQueryResult state -> m ())
         -> LSQ.ClientStAcquiring block (Query block) m Void
     clientStAcquiring query respond = LSQ.ClientStAcquiring
@@ -477,7 +479,7 @@ localStateQuery queue =
         }
 
     clientStAcquired
-        :: Query block state
+        :: forall state. Query block state
         -> (LocalStateQueryResult state -> m ())
         -> LSQ.ClientStAcquired block (Query block) m Void
     clientStAcquired query respond =
@@ -492,7 +494,7 @@ localStateQuery queue =
             LSQ.SendMsgReAcquire pt (clientStAcquiring query respond)
 
     clientStQuerying
-        :: (LocalStateQueryResult state -> m ())
+        :: forall state. (LocalStateQueryResult state -> m ())
         -> LSQ.ClientStQuerying block (Query block) m Void state
     clientStQuerying respond = LSQ.ClientStQuerying
         { recvMsgResult = \result -> do
@@ -500,7 +502,7 @@ localStateQuery queue =
             clientStAcquiredAgain
         }
 
-    awaitNextCmd :: m (LocalStateQueryCmd block state m)
+    awaitNextCmd :: m (LocalStateQueryCmd block m)
     awaitNextCmd = atomically $ readTQueue queue
 
 --------------------------------------------------------------------------------

From 2c00aa8e9a1b262e1f792caf8a97b7d26a89e482 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Fri, 12 Jun 2020 19:56:39 +0200
Subject: [PATCH 02/14] List stake pools

- Return dummy rewards, cost, margin, productions for now
- Embed LSQ queue in cursor
- Remove mock knownPools
---
 lib/shelley/cardano-wallet-shelley.cabal      |   2 +
 lib/shelley/exe/cardano-wallet-shelley.hs     |  12 +-
 lib/shelley/src/Cardano/Wallet/Shelley.hs     |  39 ++--
 .../src/Cardano/Wallet/Shelley/Api/Server.hs  |  10 +-
 .../Cardano/Wallet/Shelley/Compatibility.hs   |  53 ++++-
 .../src/Cardano/Wallet/Shelley/Network.hs     |  39 ++--
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 202 ++++++++++++++++++
 nix/.stack.nix/cardano-wallet-shelley.nix     |   1 +
 8 files changed, 315 insertions(+), 43 deletions(-)
 create mode 100644 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

diff --git a/lib/shelley/cardano-wallet-shelley.cabal b/lib/shelley/cardano-wallet-shelley.cabal
index efe039010c3..810ab4c82c5 100644
--- a/lib/shelley/cardano-wallet-shelley.cabal
+++ b/lib/shelley/cardano-wallet-shelley.cabal
@@ -67,6 +67,7 @@ library
     , retry
     , servant-server
     , shelley-spec-ledger
+    , sort
     , temporary
     , text
     , text-class
@@ -85,6 +86,7 @@ library
       Cardano.Wallet.Shelley.Network
       Cardano.Wallet.Shelley.Transaction
       Cardano.Wallet.Shelley.Launch
+      Cardano.Wallet.Shelley.Pools
 
 executable cardano-wallet-shelley
   default-language:
diff --git a/lib/shelley/exe/cardano-wallet-shelley.hs b/lib/shelley/exe/cardano-wallet-shelley.hs
index e681e1f4a58..2b8cf9eaec9 100644
--- a/lib/shelley/exe/cardano-wallet-shelley.hs
+++ b/lib/shelley/exe/cardano-wallet-shelley.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -36,6 +37,7 @@ import Cardano.CLI
     , cmdKey
     , cmdMnemonic
     , cmdNetwork
+    , cmdStakePool
     , cmdTransaction
     , cmdVersion
     , cmdWallet
@@ -63,9 +65,16 @@ import Cardano.Startup
     , withUtf8Encoding
     )
 import Cardano.Wallet.Api.Client
-    ( addressClient, networkClient, transactionClient, walletClient )
+    ( addressClient
+    , networkClient
+    , stakePoolClient
+    , transactionClient
+    , walletClient
+    )
 import Cardano.Wallet.Api.Server
     ( HostPreference, Listen (..), TlsConfiguration )
+import Cardano.Wallet.Api.Types
+    ( ApiStakePool )
 import Cardano.Wallet.Logging
     ( trMessage, transformTextTrace )
 import Cardano.Wallet.Primitive.Types
@@ -137,6 +146,7 @@ main = withUtf8Encoding $ do
         <> cmdAddress addressClient
         <> cmdTransaction transactionClient walletClient
         <> cmdNetwork networkClient
+        <> cmdStakePool @ApiStakePool stakePoolClient
         <> cmdVersion
 
 beforeMainLoop
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index 60e277838cd..d844db6739e 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -57,7 +57,7 @@ import Cardano.DB.Sqlite
 import Cardano.Wallet
     ( WalletLog )
 import Cardano.Wallet.Api
-    ( ApiLayer, ApiV2 )
+    ( ApiLayer, ApiV2, ListStakePools )
 import Cardano.Wallet.Api.Server
     ( HostPreference, Listen (..), ListenError (..), TlsConfiguration )
 import Cardano.Wallet.Api.Types
@@ -94,6 +94,7 @@ import Cardano.Wallet.Primitive.Types
     ( Address
     , Block
     , ChimericAccount
+    , Coin (..)
     , GenesisParameters (..)
     , NetworkParameters (..)
     , PoolId
@@ -109,12 +110,12 @@ import Cardano.Wallet.Shelley.Compatibility
     ( Shelley, ShelleyBlock, fromNetworkMagic, fromShelleyBlock )
 import Cardano.Wallet.Shelley.Network
     ( NetworkLayerLog, withNetworkLayer )
+import Cardano.Wallet.Shelley.Pools
+    ( StakePoolLayer (..), newStakePoolLayer )
 import Cardano.Wallet.Shelley.Transaction
     ( newTransactionLayer )
 import Cardano.Wallet.Transaction
     ( TransactionLayer )
-import Cardano.Wallet.Unsafe
-    ( unsafeFromHex )
 import Control.Applicative
     ( Const (..) )
 import Control.Tracer
@@ -141,6 +142,8 @@ import Ouroboros.Network.CodecCBORTerm
     ( CodecCBORTerm )
 import Ouroboros.Network.NodeToClient
     ( NodeToClientVersionData (..) )
+import Servant
+    ( Server )
 import System.Exit
     ( ExitCode (..) )
 import System.IOManager
@@ -230,7 +233,17 @@ serveWallet
                 randomApi <- apiLayer (newTransactionLayer proxy pm el) nl
                 icarusApi  <- apiLayer (newTransactionLayer proxy pm el ) nl
                 shelleyApi <- apiLayer (newTransactionLayer proxy pm el) nl
-                startServer proxy socket randomApi icarusApi shelleyApi mockKnownPools ntpClient
+                let spl = newStakePoolLayer (genesisParameters np) nl
+                startServer
+                    proxy
+                    socket
+                    randomApi
+                    icarusApi
+                    shelleyApi
+                    (\_wid -> listStakePools spl (Coin 0))
+                    -- TODO: read wallt balance
+                    (knownPools spl)
+                    ntpClient
                 pure ExitSuccess
 
     networkDiscriminantValFromProxy
@@ -253,15 +266,16 @@ serveWallet
         -> ApiLayer (RndState n) t ByronKey
         -> ApiLayer (SeqState n IcarusKey) t IcarusKey
         -> ApiLayer (SeqState n ShelleyKey) t ShelleyKey
+        -> Server (ListStakePools ApiStakePool)
         -> IO [PoolId]
         -> NtpClient
         -> IO ()
-    startServer _proxy socket byron icarus shelley spl ntp = do
+    startServer _proxy socket byron icarus shelley listPoolsServer kp ntp = do
         sockAddr <- getSocketName socket
         let settings = Warp.defaultSettings & setBeforeMainLoop
                 (beforeMainLoop sockAddr)
         let application = Server.serve (Proxy @(ApiV2 n ApiStakePool)) $
-                server byron icarus shelley spl ntp
+                server byron icarus shelley kp listPoolsServer ntp
         Server.start settings apiServerTracer tlsConfig socket application
 
     apiLayer
@@ -304,19 +318,6 @@ exitCodeApiServer = \case
     ListenErrorAddressAlreadyInUse _ -> 12
     ListenErrorOperationNotPermitted -> 13
 
--- | FIXME: Temporary mock stake pool layer until we can get the stake pool
--- listing working. These IDs match hard-wired operator credentials in our
--- integration setup. See 'Cardano.Wallet.Shelley.Launch'.
-mockKnownPools :: IO [PoolId]
-mockKnownPools = pure
-        [ PoolId $ unsafeFromHex
-            "5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec35"
-        , PoolId $ unsafeFromHex
-            "775af3b22eff9ff53a0bdd3ac6f8e1c5013ab68445768c476ccfc1e1c6b629b4"
-        , PoolId $ unsafeFromHex
-            "c7258ccc42a43b653aaf2f80dde3120df124ebc3a79353eed782267f78d04739"
-        ]
-
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
index 8db5b65f82c..359b1189437 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
@@ -37,6 +37,7 @@ import Cardano.Wallet.Api
     , ByronTransactions
     , ByronWallets
     , CoinSelections
+    , ListStakePools
     , Network
     , Proxy_
     , ShelleyMigrations
@@ -116,9 +117,8 @@ import Fmt
 import Network.Ntp
     ( NtpClient )
 import Servant
-    ( (:<|>) (..), Server, err501, throwError )
+    ( (:<|>) (..), Server )
 
--- | A diminished servant server to serve Byron wallets only.
 server
     :: forall t n.
         ( Buildable (ErrValidateSelection t)
@@ -130,9 +130,10 @@ server
     -> ApiLayer (SeqState n IcarusKey) t IcarusKey
     -> ApiLayer (SeqState n ShelleyKey) t ShelleyKey
     -> IO [PoolId]
+    -> Server (ListStakePools ApiStakePool)
     -> NtpClient
     -> Server (Api n ApiStakePool)
-server byron icarus shelley knownPools ntp =
+server byron icarus shelley knownPools listPoolsHandler ntp =
          wallets
     :<|> addresses
     :<|> coinSelections
@@ -176,7 +177,7 @@ server byron icarus shelley knownPools ntp =
 
     stakePools :: Server (StakePools n ApiStakePool)
     stakePools =
-             (\_ -> throwError err501)
+             listPoolsHandler
         :<|> joinStakePool shelley knownPools
         :<|> quitStakePool shelley
         :<|> delegationFee shelley
@@ -291,3 +292,4 @@ server byron icarus shelley knownPools ntp =
 
     proxy :: Server Proxy_
     proxy = postExternalTransaction icarus
+
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
index 02dbd3a4ec6..c4ce29130c1 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -52,6 +52,15 @@ module Cardano.Wallet.Shelley.Compatibility
     , toStakeKeyDeregCert
     , toStakePoolDlgCert
     , toStakeCredential
+    , toShelleyCoin
+    , fromShelleyCoin
+
+      -- ** Stake pools
+    , fromPoolId
+    , fromPoolDistr
+    , fromRewards
+    , optimumNumberOfPools
+
 
     , fromBlockNo
     , fromShelleyBlock
@@ -89,7 +98,7 @@ import Cardano.Wallet.Api.Types
 import Cardano.Wallet.Primitive.AddressDerivation
     ( NetworkDiscriminant (..), hex )
 import Cardano.Wallet.Unsafe
-    ( unsafeDeserialiseCbor )
+    ( unsafeDeserialiseCbor, unsafeMkPercentage )
 import Control.Arrow
     ( left )
 import Crypto.Hash.Algorithms
@@ -107,7 +116,7 @@ import Data.Map.Strict
 import Data.Maybe
     ( fromMaybe, mapMaybe )
 import Data.Quantity
-    ( Quantity (..), mkPercentage )
+    ( Percentage, Quantity (..), mkPercentage )
 import Data.Text
     ( Text )
 import Data.Text.Class
@@ -164,6 +173,7 @@ import qualified Shelley.Spec.Ledger.BaseTypes as SL
 import qualified Shelley.Spec.Ledger.BlockChain as SL
 import qualified Shelley.Spec.Ledger.Coin as SL
 import qualified Shelley.Spec.Ledger.Credential as SL
+import qualified Shelley.Spec.Ledger.Delegation.Certificates as SL
 import qualified Shelley.Spec.Ledger.Genesis as SL
 import qualified Shelley.Spec.Ledger.Keys as SL
 import qualified Shelley.Spec.Ledger.LedgerState as SL
@@ -513,6 +523,39 @@ fromNetworkMagic :: NetworkMagic -> W.ProtocolMagic
 fromNetworkMagic (NetworkMagic magic) =
     W.ProtocolMagic (fromIntegral magic)
 
+--
+-- Stake pools
+--
+
+fromPoolId :: SL.KeyHash 'SL.StakePool crypto -> W.PoolId
+fromPoolId (SL.KeyHash x) = W.PoolId $ getHash x
+
+fromPoolDistr
+    :: SL.PoolDistr TPraosStandardCrypto
+    -> Map W.PoolId Percentage
+fromPoolDistr =
+    Map.map (unsafeMkPercentage . fst)
+    . Map.mapKeys fromPoolId
+    . SL.unPoolDistr
+
+-- TODO: Change to return a map of maps, instead of using head
+fromRewards
+    :: O.NonMyopicMemberRewards TPraosStandardCrypto
+    -> Map W.PoolId (Quantity "lovelace" Word64)
+fromRewards =
+    Map.map (Quantity . fromIntegral)
+    . Map.mapKeys fromPoolId
+    . snd
+    . head
+    . Map.toList
+    . O.unNonMyopicMemberRewards
+
+optimumNumberOfPools :: SL.PParams -> Int
+optimumNumberOfPools = safeConvert . SL._nOpt
+  where
+    safeConvert :: Natural -> Int
+    safeConvert = fromIntegral
+
 --
 -- Txs
 --
@@ -549,6 +592,12 @@ fromShelleyCoin (SL.Coin c) = W.Coin $ unsafeCast c
     unsafeCast :: Integer -> Word64
     unsafeCast = fromIntegral
 
+toShelleyCoin :: W.Coin -> SL.Coin
+toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c
+  where
+    safeCast :: Word64 -> Integer
+    safeCast = fromIntegral
+
 -- NOTE: For resolved inputs we have to pass in a dummy value of 0.
 fromShelleyTx :: SL.Tx TPraosStandardCrypto -> (W.Tx, [W.DelegationCertificate])
 fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) =
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index ee4282530bc..415a03ff5ab 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -203,6 +203,7 @@ import qualified Shelley.Spec.Ledger.PParams as SL
 data instance Cursor (m Shelley) = Cursor
     (Point ShelleyBlock)
     (TQueue m (ChainSyncCmd ShelleyBlock m))
+    (TQueue m (LocalStateQueryCmd ShelleyBlock m))
 
 -- | Create an instance of the network layer
 withNetworkLayer
@@ -231,8 +232,7 @@ withNetworkLayer tr np addrInfo versionData action = do
 
     queryRewardQ <- connectDelegationRewardsClient handlers
 
-    action
-        NetworkLayer
+    action $ NetworkLayer
             { currentNodeTip = liftIO $ _currentNodeTip nodeTipVar
             , nextBlocks = _nextBlocks
             , initCursor = _initCursor
@@ -268,7 +268,8 @@ withNetworkLayer tr np addrInfo versionData action = do
 
     _initCursor headers = do
         chainSyncQ <- atomically newTQueue
-        client <- mkWalletClient gp chainSyncQ
+        stateQueryQ <- atomically newTQueue
+        client <- mkWalletClient tr gp chainSyncQ stateQueryQ
         let handlers = failOnConnectionLost tr
         link =<< async
             (connectClient tr handlers client versionData addrInfo)
@@ -283,18 +284,18 @@ withNetworkLayer tr np addrInfo versionData action = do
                     $ MsgIntersectionFound
                     $ fromChainHash getGenesisBlockHash
                     $ pointHash intersection
-                pure $ Cursor intersection chainSyncQ
+                pure $ Cursor intersection chainSyncQ stateQueryQ
             _ -> fail $ unwords
                 [ "initCursor: intersection not found? This can't happen"
                 , "because we always give at least the genesis point."
                 , "Here are the points we gave: " <> show headers
                 ]
 
-    _nextBlocks (Cursor _ chainSyncQ) = do
-        let toCursor point = Cursor point chainSyncQ
+    _nextBlocks (Cursor _ chainSyncQ lsqQ) = do
+        let toCursor point = Cursor point chainSyncQ lsqQ
         liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks
 
-    _cursorSlotId (Cursor point _) = do
+    _cursorSlotId (Cursor point _ _) = do
         fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point
 
     _getAccountBalance nodeTipVar queryRewardQ acct = do
@@ -357,20 +358,20 @@ type NetworkClient m = OuroborosApplication
 -- purposes of syncing blocks to a single wallet.
 mkWalletClient
     :: (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
-    => W.GenesisParameters
+    => Tracer m NetworkLayerLog
+    -> W.GenesisParameters
         -- ^ Static blockchain parameters
     -> TQueue m (ChainSyncCmd ShelleyBlock m)
         -- ^ Communication channel with the ChainSync client
+    -> TQueue m (LocalStateQueryCmd ShelleyBlock m)
+        -- ^ Communication channel with the local state query
     -> m (NetworkClient m)
-mkWalletClient gp chainSyncQ = do
+mkWalletClient tr gp chainSyncQ lsqQ = do
     stash <- atomically newTQueue
     pure $ nodeToClientProtocols (const $ return $ NodeToClientProtocols
         { localChainSyncProtocol =
-            let
-                codec = cChainSyncCodec codecs
-            in
-            InitiatorProtocolOnly $ MuxPeerRaw
-                $ \channel -> runPipelinedPeer nullTracer codec channel
+            InitiatorProtocolOnly $ MuxPeerRaw $ \channel ->
+                runPipelinedPeer nullTracer (cChainSyncCodec codecs) channel
                 $ chainSyncClientPeerPipelined
                 $ chainSyncWithBlocks (fromTip' gp) chainSyncQ stash
 
@@ -378,9 +379,14 @@ mkWalletClient gp chainSyncQ = do
             doNothingProtocol
 
         , localStateQueryProtocol =
-            doNothingProtocol
+            InitiatorProtocolOnly $ MuxPeerRaw
+                $ \channel -> runPeer tr' (cStateQueryCodec codecs) channel
+                $ localStateQueryClientPeer
+                $ localStateQuery lsqQ
         })
         NodeToClientV_2
+  where
+    tr' = contramap MsgLocalStateQuery tr
 
 -- | Construct a network client with the given communication channel, for the
 -- purposes of querying delegations and rewards.
@@ -388,8 +394,7 @@ mkDelegationRewardsClient
     :: forall m. (MonadThrow m, MonadST m, MonadTimer m)
     => Tracer m NetworkLayerLog
         -- ^ Base trace for underlying protocols
-    -> TQueue m
-       (LocalStateQueryCmd ShelleyBlock (Delegations, RewardAccounts) m)
+    -> TQueue m (LocalStateQueryCmd ShelleyBlock m)
         -- ^ Communication channel with the LocalStateQuery client
     -> NetworkClient m
 mkDelegationRewardsClient tr queryRewardQ =
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
new file mode 100644
index 00000000000..8bb31f92d7a
--- /dev/null
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+-- |
+-- Copyright: © 2020 IOHK
+-- License: Apache-2.0
+--
+-- Haskell-node "shelley" implementation of the @StakePoolLayer@ abstraction,
+-- i.e. some boring glue.
+module Cardano.Wallet.Shelley.Pools where
+
+import Prelude
+
+import Cardano.Wallet.Api.Server
+    ( LiftHandler (..), apiError )
+import Cardano.Wallet.Api.Types
+    ( ApiErrorCode (..), ApiT (..) )
+import Cardano.Wallet.Network
+    ( NetworkLayer (..) )
+import Cardano.Wallet.Primitive.Types
+    ( Coin (..), GenesisParameters (..), PoolId )
+import Cardano.Wallet.Shelley.Compatibility
+    ( Shelley
+    , ShelleyBlock
+    , fromPoolDistr
+    , fromRewards
+    , optimumNumberOfPools
+    , toPoint
+    , toShelleyCoin
+    )
+import Cardano.Wallet.Shelley.Network
+    ( pattern Cursor )
+import Cardano.Wallet.Unsafe
+    ( unsafeMkPercentage, unsafeRunExceptT )
+import Control.Monad.Class.MonadSTM
+    ( MonadSTM, TQueue )
+import Control.Monad.IO.Class
+    ( liftIO )
+import Control.Monad.Trans.Except
+    ( ExceptT (..), runExceptT, withExceptT )
+import Data.Map
+    ( Map )
+import Data.Map.Merge.Strict
+    ( dropMissing, traverseMissing, zipWithMatched )
+import Data.Ord
+    ( Down (..) )
+import Data.Quantity
+    ( Percentage (..), Quantity (..) )
+import Data.Sort
+    ( sortOn )
+import Data.Word
+    ( Word64 )
+import GHC.Generics
+    ( Generic )
+import Ouroboros.Network.Block
+    ( Point )
+import Ouroboros.Network.Client.Wallet
+    ( LocalStateQueryCmd (..), send )
+import Servant
+    ( Handler, err500 )
+
+import qualified Cardano.Wallet.Api.Types as Api
+import qualified Data.Map.Merge.Strict as Map
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Ouroboros.Consensus.Shelley.Ledger as OC
+
+-- | Stake Pool Data fields fetched from the node via LSQ
+data PoolLsqMetrics = PoolLsqMetrics
+    { nonMyopicMemberRewards :: Quantity "lovelace" Word64
+    , stake :: Percentage
+    , saturation :: Double
+    } deriving (Eq, Show, Generic)
+
+
+data ErrFetchMetrics = ErrFetchMetrics
+  deriving Show
+
+askNode
+    :: MonadSTM m
+    => TQueue m (LocalStateQueryCmd ShelleyBlock m)
+    -> Point ShelleyBlock
+    -> Coin
+    -> ExceptT ErrFetchMetrics m (Map PoolId PoolLsqMetrics)
+askNode queue pt coin = do
+    stakeMap <- fromPoolDistr <$> handleQueryFailure
+        (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution)
+    let toStake = Set.singleton $ Left $ toShelleyCoin coin
+    rewardMap <- fromRewards <$> handleQueryFailure
+        (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake))
+    pparams <- handleQueryFailure
+        (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams)
+
+    return $ combine
+        (optimumNumberOfPools pparams)
+        stakeMap
+        rewardMap
+  where
+    handleQueryFailure = withExceptT (const ErrFetchMetrics) . ExceptT
+
+    combine
+        :: Int -- ^ Desired number of pools
+        -> Map PoolId Percentage
+        -> Map PoolId (Quantity "lovelace" Word64)
+        -> Map PoolId PoolLsqMetrics
+    combine nOpt =
+        Map.merge stakeButNoRew rewardsButNoStake bothPresent
+      where
+        -- calculate the saturation from the relative stake
+        sat s = fromRational $ (getPercentage s) / (1 / fromIntegral nOpt)
+
+        -- Haven't figured out how to fetch non-myopic member rewards properly yet.
+        -- Let's provide a default value of 0, at least for now.
+        stakeButNoRew     = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
+            { nonMyopicMemberRewards = Quantity 0
+            , stake = s
+            , saturation = (sat s)
+            }
+
+        rewardsButNoStake = dropMissing
+
+        bothPresent       = zipWithMatched  $ \_k s r -> PoolLsqMetrics r s (sat s)
+
+readBlockProductions :: IO (Map PoolId Int)
+readBlockProductions = return Map.empty
+
+--
+-- Api Server Handler
+--
+
+instance LiftHandler ErrFetchMetrics where
+    handler = \case
+        ErrFetchMetrics ->
+            apiError err500 NotSynced $ mconcat
+                [ "There was a problem fetching metrics from the node."
+                ]
+
+data StakePoolLayer = StakePoolLayer
+    { knownPools :: IO [PoolId]
+    , listStakePools :: Coin -> Handler [Api.ApiStakePool]
+      -- TODO: Maybe weird type, but let's do it for now.
+    }
+
+
+newStakePoolLayer
+    :: GenesisParameters
+    -> NetworkLayer IO (IO Shelley) b
+    -> StakePoolLayer
+newStakePoolLayer gp nl = StakePoolLayer
+    { knownPools = _knownPools
+    , listStakePools = _listPools
+    }
+  where
+    dummyCoin = Coin 0
+
+    -- Note: We shouldn't have to do this conversion.
+    el = getEpochLength gp
+    gh = getGenesisBlockHash gp
+    getTip = fmap (toPoint gh el) . liftIO $ unsafeRunExceptT $ currentNodeTip nl
+
+    _knownPools
+        :: IO [PoolId]
+    _knownPools = do
+        Cursor _workerTip _ lsqQ <- initCursor nl []
+        pt <- getTip
+        res <- runExceptT $ map fst . Map.toList <$> askNode lsqQ pt dummyCoin
+        case res of
+            Right x -> return x
+            Left _e -> return []
+
+
+    _listPools
+        :: Coin
+        -- ^ The amount of stake the user intends to delegate, which may affect the
+        -- ranking of the pools.
+        -> Handler [Api.ApiStakePool]
+    _listPools s = liftHandler $ do
+            Cursor _workerTip _ lsqQ <- liftIO $ initCursor nl []
+            pt <- liftIO getTip
+            map mkApiPool
+                . sortOn (Down . nonMyopicMemberRewards . snd)
+                . Map.toList <$> askNode lsqQ pt s
+      where
+        mkApiPool (pid, PoolLsqMetrics prew pstk psat) = Api.ApiStakePool
+            { Api.id = (ApiT pid)
+            , Api.metrics = Api.ApiStakePoolMetrics
+                { Api.nonMyopicMemberRewards = (mapQ fromIntegral prew)
+                , Api.relativeStake = Quantity pstk
+                , Api.saturation = psat
+                , Api.producedBlocks = Quantity 0 -- TODO: Implement
+                }
+            , Api.metadata = Nothing -- TODO: Implement
+            , Api.cost = Quantity 0 -- TODO: Implement
+            , Api.margin = Quantity $ unsafeMkPercentage 0 -- TODO: Implement
+            }
+
+        mapQ f (Quantity x) = Quantity $ f x
diff --git a/nix/.stack.nix/cardano-wallet-shelley.nix b/nix/.stack.nix/cardano-wallet-shelley.nix
index cfe7d7ee7a4..132e42141e0 100644
--- a/nix/.stack.nix/cardano-wallet-shelley.nix
+++ b/nix/.stack.nix/cardano-wallet-shelley.nix
@@ -64,6 +64,7 @@
           (hsPkgs."retry" or (errorHandler.buildDepError "retry"))
           (hsPkgs."servant-server" or (errorHandler.buildDepError "servant-server"))
           (hsPkgs."shelley-spec-ledger" or (errorHandler.buildDepError "shelley-spec-ledger"))
+          (hsPkgs."sort" or (errorHandler.buildDepError "sort"))
           (hsPkgs."temporary" or (errorHandler.buildDepError "temporary"))
           (hsPkgs."text" or (errorHandler.buildDepError "text"))
           (hsPkgs."text-class" or (errorHandler.buildDepError "text-class"))

From c9050cd070420f8936c01e977c18540cdffa799b Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Sat, 13 Jun 2020 16:12:18 +0200
Subject: [PATCH 03/14] Remove mock pool ids from integration tests

---
 .../Scenario/API/Shelley/StakePools.hs        | 71 ++++++++++++-------
 1 file changed, 44 insertions(+), 27 deletions(-)

diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
index 25753af8867..6cc2afd576b 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -14,7 +14,8 @@ module Test.Integration.Scenario.API.Shelley.StakePools
 import Prelude
 
 import Cardano.Wallet.Api.Types
-    ( ApiT (..)
+    ( ApiStakePool
+    , ApiT (..)
     , ApiTransaction
     , ApiWallet
     , DecodeAddress
@@ -22,15 +23,13 @@ import Cardano.Wallet.Api.Types
     , WalletStyle (..)
     )
 import Cardano.Wallet.Primitive.AddressDerivation
-    ( PaymentAddress, fromHex )
+    ( PaymentAddress )
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Primitive.Types
     ( Direction (..), PoolId (..), TxStatus (..) )
-import Data.ByteString
-    ( ByteString )
 import Data.Generics.Internal.VL.Lens
-    ( (^.) )
+    ( view, (^.) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text.Class
@@ -60,6 +59,7 @@ import Test.Integration.Framework.DSL
     , notDelegating
     , quitStakePool
     , request
+    , unsafeRequest
     , verify
     , waitForNextEpoch
     , walletId
@@ -105,14 +105,18 @@ spec = do
 
     it "STAKE_POOLS_JOIN_01 - Cannot join existant stakepool with wrong password" $ \ctx -> do
         w <- fixtureWallet ctx
-        joinStakePool @n ctx (ApiT poolIdMock) (w, "Wrong Passphrase") >>= flip verify
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+        joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify
             [ expectResponseCode HTTP.status403
             , expectErrorMessage errMsg403WrongPass
             ]
 
     it "STAKE_POOLS_JOIN_02 - Cannot join already joined stake pool" $ \ctx -> do
         w <- fixtureWallet ctx
-        joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+        joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -127,14 +131,16 @@ spec = do
                 , expectListField 0
                     (#status . #getApiT) (`shouldBe` InLedger)
                 ]
-        joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
+        joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status403
-            , expectErrorMessage (errMsg403PoolAlreadyJoined $ toText poolIdMock)
+            , expectErrorMessage (errMsg403PoolAlreadyJoined $ toText $ getApiT pool)
             ]
 
     it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> do
         w <- fixtureWallet ctx
-        joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+        joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -170,7 +176,10 @@ spec = do
         (currentEpoch, sp) <- getSlotParams ctx
         waitForNextEpoch ctx
 
-        joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
+        pool1:pool2:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+
+        joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -189,17 +198,17 @@ spec = do
         request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
             [ expectField #delegation
                 (`shouldBe` notDelegating
-                    [ (Just (ApiT poolIdMock), mkEpochInfo (currentEpoch + 3) sp)
+                    [ (Just pool1, mkEpochInfo (currentEpoch + 3) sp)
                     ]
                 )
             ]
         eventually "Wallet is delegating to p1" $ do
             request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
-                [ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
+                [ expectField #delegation (`shouldBe` delegating pool1 [])
                 ]
 
         -- join another stake pool
-        joinStakePool @n ctx (ApiT poolIdMock') (w, fixturePassphrase) >>= flip verify
+        joinStakePool @n ctx pool2 (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -217,7 +226,7 @@ spec = do
 
         eventually "Wallet is delegating to p2" $ do
             request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
-                [ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock') [])
+                [ expectField #delegation (`shouldBe` delegating pool2 [])
                 ]
 
         --quiting
@@ -244,8 +253,10 @@ spec = do
 
     xit "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \ctx -> do
         w <- fixtureWallet ctx
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
         -- Join a pool
-        joinStakePool @n ctx (ApiT poolIdMock) (w, fixturePassphrase) >>= flip verify
+        joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
             , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -305,7 +316,11 @@ spec = do
             \I can join if I have just the right amount" $ \ctx -> do
             let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
             w <- fixtureWalletWith @n ctx [fee]
-            joinStakePool @n ctx (ApiT poolIdMock) (w, passwd)>>= flip verify
+
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+
+            joinStakePool @n ctx pool (w, passwd)>>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
                 , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -315,7 +330,9 @@ spec = do
            \I cannot join if I have not enough fee to cover" $ \ctx -> do
             let (fee, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
             w <- fixtureWalletWith @n ctx [fee - 1]
-            joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+            joinStakePool @n ctx pool (w, passwd) >>= flip verify
                 [ expectResponseCode HTTP.status403
                 , expectErrorMessage (errMsg403DelegationFee 1)
                 ]
@@ -327,8 +344,9 @@ spec = do
             let (feeQuit, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
             let initBalance = [feeJoin + feeQuit]
             w <- fixtureWalletWith @n ctx initBalance
-
-            joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+            joinStakePool @n ctx pool (w, passwd) >>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
                 , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -336,7 +354,7 @@ spec = do
 
             eventually "Wallet is delegating to p1" $ do
                 request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
-                    [ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
+                    [ expectField #delegation (`shouldBe` delegating pool [])
                     ]
 
             quitStakePool @n ctx (w, passwd) >>= flip verify
@@ -359,7 +377,10 @@ spec = do
             let initBalance = [feeJoin+1]
             w <- fixtureWalletWith @n ctx initBalance
 
-            joinStakePool @n ctx (ApiT poolIdMock) (w, passwd) >>= flip verify
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools w) Empty
+
+            joinStakePool @n ctx pool (w, passwd) >>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
                 , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -367,7 +388,7 @@ spec = do
 
             eventually "Wallet is delegating to p1" $ do
                 request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
-                    [ expectField #delegation (`shouldBe` delegating (ApiT poolIdMock) [])
+                    [ expectField #delegation (`shouldBe` delegating pool [])
                     ]
             quitStakePool @n ctx (w, passwd) >>= flip verify
                 [ expectResponseCode HTTP.status403
@@ -393,8 +414,4 @@ spec = do
             ]
 
   where
-    (Right poolID) = fromHex @ByteString "5a7b67c7dcfa8c4c25796bea05bcdfca01590c8c7612cc537c97012bed0dec35"
-    poolIdMock = PoolId poolID
-    (Right poolID') = fromHex @ByteString "775af3b22eff9ff53a0bdd3ac6f8e1c5013ab68445768c476ccfc1e1c6b629b4"
-    poolIdMock' = PoolId poolID'
     passwd = "Secure Passphrase"

From 31c7cb5714e7c147d988be54e6cc359cc91acdf6 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 13:20:04 +0200
Subject: [PATCH 04/14] Add integration test for listing stake pools

---
 .../Scenario/API/Shelley/StakePools.hs        | 56 +++++++++++++++++++
 1 file changed, 56 insertions(+)

diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
index 6cc2afd576b..5f42b27859c 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -48,6 +48,7 @@ import Test.Integration.Framework.DSL
     , expectErrorMessage
     , expectField
     , expectListField
+    , expectListSize
     , expectResponseCode
     , fixturePassphrase
     , fixtureWallet
@@ -65,6 +66,7 @@ import Test.Integration.Framework.DSL
     , walletId
     , (.<=)
     , (.>)
+    , (.>=)
     )
 import Test.Integration.Framework.TestData
     ( errMsg403DelegationFee
@@ -413,5 +415,59 @@ spec = do
             , expectErrorMessage $ errMsg403DelegationFee fee
             ]
 
+    it "STAKE_POOLS_LIST_01 - List stake pools" $ \ctx -> do
+        w <- fixtureWallet ctx
+        eventually "Listing stake pools shows expected information" $ do
+            r <- request @[ApiStakePool] ctx (Link.listStakePools w) Default Empty
+            expectResponseCode HTTP.status200 r
+            verify r
+                [ expectListSize 3
+
+-- Pending a mock metadata registry
+--                , expectListField 0
+--                    #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))
+--                , expectListField 1
+--                    #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))
+--                , expectListField 2
+--                    #metadata ((`shouldBe` Just "Genesis Pool") . fmap (view #name . getApiT))
+
+                , expectListField 0
+                    #cost (`shouldBe` (Quantity 0))
+                , expectListField 1
+                    #cost (`shouldBe` (Quantity 0))
+                , expectListField 2
+                    #cost (`shouldBe` (Quantity 0))
+
+                , expectListField 0
+                    #margin (`shouldBe` (Quantity minBound))
+                , expectListField 1
+                    #margin (`shouldBe` (Quantity minBound))
+                , expectListField 2
+                    #margin (`shouldBe` (Quantity minBound))
+
+-- Pending stake pools producing blocks in our setup,
+-- AND pending keeping track of block producions
+--                , expectListField 0
+--                    (#metrics . #producedBlocks) (.>= Quantity 0)
+--                , expectListField 1
+--                    (#metrics . #producedBlocks) (.>= Quantity 0)
+--                , expectListField 2
+--                    (#metrics . #producedBlocks) (.>= Quantity 0)
+--
+--                , expectListField 0
+--                    (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)
+--                , expectListField 1
+--                    (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)
+--                , expectListField 2
+--                    (#metrics . #nonMyopicMemberRewards) (.>= Quantity 0)
+
+                , expectListField 0
+                    (#metrics . #saturation) (.>= 0)
+                , expectListField 1
+                    (#metrics . #saturation) (.>= 0)
+                , expectListField 2
+                    (#metrics . #saturation) (.>= 0)
+                ]
+
   where
     passwd = "Secure Passphrase"

From cdc4ad78e136b3328ed345db2f4a4822be34c077 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:03:39 +0200
Subject: [PATCH 05/14] Actually read wallet balance when listing pools (w/
 test and swagger for failure)

Also, now passing around spl instead of a separate server for the
list stake pool endpoint.
---
 .../Scenario/API/Shelley/StakePools.hs        | 13 +++++++--
 lib/core/src/Cardano/Wallet/Api/Server.hs     |  1 +
 lib/shelley/src/Cardano/Wallet/Shelley.hs     | 18 ++++---------
 .../src/Cardano/Wallet/Shelley/Api/Server.hs  | 27 +++++++++++++------
 .../src/Cardano/Wallet/Shelley/Pools.hs       |  9 +++----
 specifications/api/swagger.yaml               |  4 ++-
 6 files changed, 43 insertions(+), 29 deletions(-)

diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
index 5f42b27859c..83b3da65989 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -27,13 +27,13 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Primitive.Types
-    ( Direction (..), PoolId (..), TxStatus (..) )
+    ( Direction (..), PoolId (..), TxStatus (..), WalletId )
 import Data.Generics.Internal.VL.Lens
     ( view, (^.) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text.Class
-    ( toText )
+    ( fromText, toText )
 import Test.Hspec
     ( SpecWith, describe, it, shouldBe, xit )
 import Test.Integration.Framework.DSL
@@ -79,6 +79,7 @@ import Test.Integration.Framework.TestData
 
 import qualified Cardano.Wallet.Api.Link as Link
 import qualified Data.ByteString as BS
+import qualified Data.Text as T
 import qualified Network.HTTP.Types.Status as HTTP
 
 
@@ -469,5 +470,13 @@ spec = do
                     (#metrics . #saturation) (.>= 0)
                 ]
 
+    it "STAKE_POOLS_LIST_05 - Fails for unknown wallets" $ \ctx -> do
+        -- FIXME: Type inference breaks without this line:
+        _w <- fixtureWallet ctx
+
+        r <- request @[ApiStakePool] ctx (Link.listStakePools (ApiT invalidWalletId, ())) Default Empty
+        expectResponseCode HTTP.status404 r
   where
+    invalidWalletId :: WalletId
+    invalidWalletId = either (error . show) id $ fromText $ T.pack $ replicate 40 '0'
     passwd = "Secure Passphrase"
diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
index 3261ee1f24a..a1e7833ee2f 100644
--- a/lib/core/src/Cardano/Wallet/Api/Server.hs
+++ b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -81,6 +81,7 @@ module Cardano.Wallet.Api.Server
     , withLegacyLayer'
     , rndStateChange
     , assignMigrationAddresses
+    , withWorkerCtx
     ) where
 
 import Prelude
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index d844db6739e..0bd2eaeb7fb 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -57,7 +57,7 @@ import Cardano.DB.Sqlite
 import Cardano.Wallet
     ( WalletLog )
 import Cardano.Wallet.Api
-    ( ApiLayer, ApiV2, ListStakePools )
+    ( ApiLayer, ApiV2 )
 import Cardano.Wallet.Api.Server
     ( HostPreference, Listen (..), ListenError (..), TlsConfiguration )
 import Cardano.Wallet.Api.Types
@@ -94,11 +94,8 @@ import Cardano.Wallet.Primitive.Types
     ( Address
     , Block
     , ChimericAccount
-    , Coin (..)
     , GenesisParameters (..)
     , NetworkParameters (..)
-    , PoolId
-    , PoolId (..)
     , SyncTolerance
     , WalletId
     )
@@ -142,8 +139,6 @@ import Ouroboros.Network.CodecCBORTerm
     ( CodecCBORTerm )
 import Ouroboros.Network.NodeToClient
     ( NodeToClientVersionData (..) )
-import Servant
-    ( Server )
 import System.Exit
     ( ExitCode (..) )
 import System.IOManager
@@ -240,9 +235,7 @@ serveWallet
                     randomApi
                     icarusApi
                     shelleyApi
-                    (\_wid -> listStakePools spl (Coin 0))
-                    -- TODO: read wallt balance
-                    (knownPools spl)
+                    spl
                     ntpClient
                 pure ExitSuccess
 
@@ -266,16 +259,15 @@ serveWallet
         -> ApiLayer (RndState n) t ByronKey
         -> ApiLayer (SeqState n IcarusKey) t IcarusKey
         -> ApiLayer (SeqState n ShelleyKey) t ShelleyKey
-        -> Server (ListStakePools ApiStakePool)
-        -> IO [PoolId]
+        -> StakePoolLayer
         -> NtpClient
         -> IO ()
-    startServer _proxy socket byron icarus shelley listPoolsServer kp ntp = do
+    startServer _proxy socket byron icarus shelley spl ntp = do
         sockAddr <- getSocketName socket
         let settings = Warp.defaultSettings & setBeforeMainLoop
                 (beforeMainLoop sockAddr)
         let application = Server.serve (Proxy @(ApiV2 n ApiStakePool)) $
-                server byron icarus shelley kp listPoolsServer ntp
+                server byron icarus shelley spl ntp
         Server.start settings apiServerTracer tlsConfig socket application
 
     apiLayer
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
index 359b1189437..624e13fc1a2 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs
@@ -37,7 +37,6 @@ import Cardano.Wallet.Api
     , ByronTransactions
     , ByronWallets
     , CoinSelections
-    , ListStakePools
     , Network
     , Proxy_
     , ShelleyMigrations
@@ -46,7 +45,8 @@ import Cardano.Wallet.Api
     , Wallets
     )
 import Cardano.Wallet.Api.Server
-    ( delegationFee
+    ( LiftHandler (liftE)
+    , delegationFee
     , deleteTransaction
     , deleteWallet
     , getMigrationInfo
@@ -83,6 +83,7 @@ import Cardano.Wallet.Api.Server
     , selectCoins
     , withLegacyLayer
     , withLegacyLayer'
+    , withWorkerCtx
     )
 import Cardano.Wallet.Api.Types
     ( ApiStakePool, ApiT (..), SomeByronWalletPostData (..) )
@@ -98,8 +99,12 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random
     ( RndState )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( SeqState )
+import Cardano.Wallet.Primitive.Model
+    ( totalBalance )
 import Cardano.Wallet.Primitive.Types
-    ( PoolId )
+    ( Coin (..) )
+import Cardano.Wallet.Shelley.Pools
+    ( StakePoolLayer (..) )
 import Control.Applicative
     ( liftA2 )
 import Control.Monad.Trans.Except
@@ -119,6 +124,8 @@ import Network.Ntp
 import Servant
     ( (:<|>) (..), Server )
 
+import qualified Cardano.Wallet as W
+
 server
     :: forall t n.
         ( Buildable (ErrValidateSelection t)
@@ -129,11 +136,10 @@ server
     => ApiLayer (RndState n) t ByronKey
     -> ApiLayer (SeqState n IcarusKey) t IcarusKey
     -> ApiLayer (SeqState n ShelleyKey) t ShelleyKey
-    -> IO [PoolId]
-    -> Server (ListStakePools ApiStakePool)
+    -> StakePoolLayer
     -> NtpClient
     -> Server (Api n ApiStakePool)
-server byron icarus shelley knownPools listPoolsHandler ntp =
+server byron icarus shelley spl ntp =
          wallets
     :<|> addresses
     :<|> coinSelections
@@ -177,8 +183,13 @@ server byron icarus shelley knownPools listPoolsHandler ntp =
 
     stakePools :: Server (StakePools n ApiStakePool)
     stakePools =
-             listPoolsHandler
-        :<|> joinStakePool shelley knownPools
+        (\(ApiT wid) -> do
+            stake <- withWorkerCtx shelley wid liftE liftE $ \wrk -> do
+                (w, _, pending) <- liftHandler $ W.readWallet wrk wid
+                return $ Coin $ fromIntegral $ totalBalance pending w
+            liftHandler $ listStakePools spl stake
+        )
+        :<|> joinStakePool shelley (knownPools spl)
         :<|> quitStakePool shelley
         :<|> delegationFee shelley
 
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 8bb31f92d7a..8df113a8394 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -62,7 +62,7 @@ import Ouroboros.Network.Block
 import Ouroboros.Network.Client.Wallet
     ( LocalStateQueryCmd (..), send )
 import Servant
-    ( Handler, err500 )
+    ( err500 )
 
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Data.Map.Merge.Strict as Map
@@ -142,8 +142,7 @@ instance LiftHandler ErrFetchMetrics where
 
 data StakePoolLayer = StakePoolLayer
     { knownPools :: IO [PoolId]
-    , listStakePools :: Coin -> Handler [Api.ApiStakePool]
-      -- TODO: Maybe weird type, but let's do it for now.
+    , listStakePools :: Coin -> ExceptT ErrFetchMetrics IO [Api.ApiStakePool]
     }
 
 
@@ -178,8 +177,8 @@ newStakePoolLayer gp nl = StakePoolLayer
         :: Coin
         -- ^ The amount of stake the user intends to delegate, which may affect the
         -- ranking of the pools.
-        -> Handler [Api.ApiStakePool]
-    _listPools s = liftHandler $ do
+        -> ExceptT ErrFetchMetrics IO [Api.ApiStakePool]
+    _listPools s = do
             Cursor _workerTip _ lsqQ <- liftIO $ initCursor nl []
             pt <- liftIO getTip
             map mkApiPool
diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml
index c108b2e0d65..363b485d4ad 100644
--- a/specifications/api/swagger.yaml
+++ b/specifications/api/swagger.yaml
@@ -1927,7 +1927,9 @@ paths:
         Some pools _may_ also have metadata attached to them.
       parameters:
         - *parametersWalletId
-      responses: *responsesListStakePools
+      responses:
+        - *responsesListStakePools
+        - *responsesErr404
 
   /stake-pools/{stakePoolId}/wallets/{walletId}:
     put:

From b36cfe6bebe49b961356d60cd36196b47a9b901e Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:23:00 +0200
Subject: [PATCH 06/14] Generalize fromRewards, rename to
 fromNonMyopicMemberRewards

---
 .../Cardano/Wallet/Shelley/Compatibility.hs   | 19 +++++++++----------
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 10 ++++++++--
 2 files changed, 17 insertions(+), 12 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
index c4ce29130c1..04dfd832943 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -58,7 +58,7 @@ module Cardano.Wallet.Shelley.Compatibility
       -- ** Stake pools
     , fromPoolId
     , fromPoolDistr
-    , fromRewards
+    , fromNonMyopicMemberRewards
     , optimumNumberOfPools
 
 
@@ -103,6 +103,8 @@ import Control.Arrow
     ( left )
 import Crypto.Hash.Algorithms
     ( Blake2b_256 (..) )
+import Data.Bifunctor
+    ( bimap )
 import Data.ByteArray.Encoding
     ( Base (Base16), convertFromBase )
 import Data.ByteString
@@ -538,16 +540,13 @@ fromPoolDistr =
     . Map.mapKeys fromPoolId
     . SL.unPoolDistr
 
--- TODO: Change to return a map of maps, instead of using head
-fromRewards
+-- NOTE: This function disregards results that are using staking keys
+fromNonMyopicMemberRewards
     :: O.NonMyopicMemberRewards TPraosStandardCrypto
-    -> Map W.PoolId (Quantity "lovelace" Word64)
-fromRewards =
-    Map.map (Quantity . fromIntegral)
-    . Map.mapKeys fromPoolId
-    . snd
-    . head
-    . Map.toList
+    -> Map (Either W.Coin W.ChimericAccount) (Map W.PoolId (Quantity "lovelace" Word64))
+fromNonMyopicMemberRewards =
+    Map.map (Map.map (Quantity . fromIntegral) . Map.mapKeys fromPoolId)
+    . Map.mapKeys (bimap fromShelleyCoin fromStakeCredential)
     . O.unNonMyopicMemberRewards
 
 optimumNumberOfPools :: SL.PParams -> Int
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 8df113a8394..9455a9ccb28 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -27,8 +27,8 @@ import Cardano.Wallet.Primitive.Types
 import Cardano.Wallet.Shelley.Compatibility
     ( Shelley
     , ShelleyBlock
+    , fromNonMyopicMemberRewards
     , fromPoolDistr
-    , fromRewards
     , optimumNumberOfPools
     , toPoint
     , toShelleyCoin
@@ -47,6 +47,8 @@ import Data.Map
     ( Map )
 import Data.Map.Merge.Strict
     ( dropMissing, traverseMissing, zipWithMatched )
+import Data.Maybe
+    ( fromMaybe )
 import Data.Ord
     ( Down (..) )
 import Data.Quantity
@@ -91,11 +93,15 @@ askNode queue pt coin = do
     stakeMap <- fromPoolDistr <$> handleQueryFailure
         (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution)
     let toStake = Set.singleton $ Left $ toShelleyCoin coin
-    rewardMap <- fromRewards <$> handleQueryFailure
+    rewardsPerAccount <- fromNonMyopicMemberRewards <$> handleQueryFailure
         (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake))
     pparams <- handleQueryFailure
         (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams)
 
+    let rewardMap = fromMaybe
+            (error "askNode: requested rewards not included in response")
+            (Map.lookup (Left coin) rewardsPerAccount)
+
     return $ combine
         (optimumNumberOfPools pparams)
         stakeMap

From 5f93fcd9cee368ea11069a0337051f8894558b45 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:25:34 +0200
Subject: [PATCH 07/14] Fix mislabeled safeConvert

---
 lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
index 04dfd832943..d5339d16095 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -550,10 +550,11 @@ fromNonMyopicMemberRewards =
     . O.unNonMyopicMemberRewards
 
 optimumNumberOfPools :: SL.PParams -> Int
-optimumNumberOfPools = safeConvert . SL._nOpt
+optimumNumberOfPools = unsafeConvert . SL._nOpt
   where
-    safeConvert :: Natural -> Int
-    safeConvert = fromIntegral
+    -- A value of ~100 can be expected, so should be fine.
+    unsafeConvert :: Natural -> Int
+    unsafeConvert = fromIntegral
 
 --
 -- Txs

From 05256b73f9c0d44978b54be51a0b7edf832ca336 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:28:33 +0200
Subject: [PATCH 08/14] Rename stake -> relativeStake

---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 9455a9ccb28..d984ac81cc3 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -75,7 +75,7 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as OC
 -- | Stake Pool Data fields fetched from the node via LSQ
 data PoolLsqMetrics = PoolLsqMetrics
     { nonMyopicMemberRewards :: Quantity "lovelace" Word64
-    , stake :: Percentage
+    , relativeStake :: Percentage
     , saturation :: Double
     } deriving (Eq, Show, Generic)
 
@@ -124,7 +124,7 @@ askNode queue pt coin = do
         -- Let's provide a default value of 0, at least for now.
         stakeButNoRew     = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
             { nonMyopicMemberRewards = Quantity 0
-            , stake = s
+            , relativeStake = s
             , saturation = (sat s)
             }
 

From c6ddbea6415ea12ef38be1a43a1555a7a17e900e Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:30:31 +0200
Subject: [PATCH 09/14] Rename stakeButNoRew -> stakeButNoRewards

---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index d984ac81cc3..4c3bbb0cd51 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -115,14 +115,14 @@ askNode queue pt coin = do
         -> Map PoolId (Quantity "lovelace" Word64)
         -> Map PoolId PoolLsqMetrics
     combine nOpt =
-        Map.merge stakeButNoRew rewardsButNoStake bothPresent
+        Map.merge stakeButNoRewards rewardsButNoStake bothPresent
       where
         -- calculate the saturation from the relative stake
         sat s = fromRational $ (getPercentage s) / (1 / fromIntegral nOpt)
 
         -- Haven't figured out how to fetch non-myopic member rewards properly yet.
         -- Let's provide a default value of 0, at least for now.
-        stakeButNoRew     = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
+        stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
             { nonMyopicMemberRewards = Quantity 0
             , relativeStake = s
             , saturation = (sat s)

From b65293b4c54fc298b10f2adcfdcde61bc5dec4e1 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:36:40 +0200
Subject: [PATCH 10/14] askNode -> fetchLsqPoolMetrics, improve docs

---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 4c3bbb0cd51..41688cf29b6 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -83,13 +83,15 @@ data PoolLsqMetrics = PoolLsqMetrics
 data ErrFetchMetrics = ErrFetchMetrics
   deriving Show
 
-askNode
+-- | Fetches information about pools availible over LSQ from the node, at the
+-- nodes' tip.
+fetchLsqPoolMetrics
     :: MonadSTM m
     => TQueue m (LocalStateQueryCmd ShelleyBlock m)
     -> Point ShelleyBlock
     -> Coin
     -> ExceptT ErrFetchMetrics m (Map PoolId PoolLsqMetrics)
-askNode queue pt coin = do
+fetchLsqPoolMetrics queue pt coin = do
     stakeMap <- fromPoolDistr <$> handleQueryFailure
         (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution)
     let toStake = Set.singleton $ Left $ toShelleyCoin coin
@@ -173,7 +175,8 @@ newStakePoolLayer gp nl = StakePoolLayer
     _knownPools = do
         Cursor _workerTip _ lsqQ <- initCursor nl []
         pt <- getTip
-        res <- runExceptT $ map fst . Map.toList <$> askNode lsqQ pt dummyCoin
+        res <- runExceptT $ map fst . Map.toList
+            <$> fetchLsqPoolMetrics lsqQ pt dummyCoin
         case res of
             Right x -> return x
             Left _e -> return []
@@ -189,7 +192,7 @@ newStakePoolLayer gp nl = StakePoolLayer
             pt <- liftIO getTip
             map mkApiPool
                 . sortOn (Down . nonMyopicMemberRewards . snd)
-                . Map.toList <$> askNode lsqQ pt s
+                . Map.toList <$> fetchLsqPoolMetrics lsqQ pt s
       where
         mkApiPool (pid, PoolLsqMetrics prew pstk psat) = Api.ApiStakePool
             { Api.id = (ApiT pid)

From cacff5590ed5f77ba6aa0d5e6420e968733f1f99 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:40:51 +0200
Subject: [PATCH 11/14] Adjust comment on stakeButNoRewards merge-case

---
 lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 41688cf29b6..4092d241b64 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -122,8 +122,9 @@ fetchLsqPoolMetrics queue pt coin = do
         -- calculate the saturation from the relative stake
         sat s = fromRational $ (getPercentage s) / (1 / fromIntegral nOpt)
 
-        -- Haven't figured out how to fetch non-myopic member rewards properly yet.
-        -- Let's provide a default value of 0, at least for now.
+        -- 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
+        -- to 0 here:
         stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
             { nonMyopicMemberRewards = Quantity 0
             , relativeStake = s

From 0ec2e2bf791dfd4e50b00b8afb2f52d44ddcfc32 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 16:59:05 +0200
Subject: [PATCH 12/14] Add: STAKE_POOLS_LIST_06 - NonMyopicMemberRewards are 0
 for empty wallets

---
 .../Scenario/API/Shelley/StakePools.hs            | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
index 83b3da65989..e3402b886b9 100644
--- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
+++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -476,6 +476,21 @@ spec = do
 
         r <- request @[ApiStakePool] ctx (Link.listStakePools (ApiT invalidWalletId, ())) Default Empty
         expectResponseCode HTTP.status404 r
+
+    it "STAKE_POOLS_LIST_06 - NonMyopicMemberRewards are 0 for empty wallets" $ \ctx -> do
+        w <- emptyWallet ctx
+        eventually "Listing stake pools shows expected information" $ do
+            r <- request @[ApiStakePool] ctx (Link.listStakePools w) Default Empty
+            expectResponseCode HTTP.status200 r
+            verify r
+                [ expectListSize 3
+                , expectListField 0
+                    (#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
+                , expectListField 1
+                    (#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
+                , expectListField 2
+                    (#metrics . #nonMyopicMemberRewards) (`shouldBe` Quantity 0)
+                ]
   where
     invalidWalletId :: WalletId
     invalidWalletId = either (error . show) id $ fromText $ T.pack $ replicate 40 '0'

From da27707bd5038dc51af9cbe024f4481709ce1f98 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Mon, 15 Jun 2020 20:01:24 +0200
Subject: [PATCH 13/14] fixup: embed responsesErr404 in responsesListStakePools
 itself

---
 specifications/api/swagger.yaml | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml
index 363b485d4ad..49fecd7dea9 100644
--- a/specifications/api/swagger.yaml
+++ b/specifications/api/swagger.yaml
@@ -1610,6 +1610,7 @@ x-responsesListAddresses: &responsesListAddresses
 
 x-responsesListStakePools: &responsesListStakePools
   <<: *responsesErr405
+  <<: *responsesErr404
   200:
     description: Ok
     content:
@@ -1927,9 +1928,7 @@ paths:
         Some pools _may_ also have metadata attached to them.
       parameters:
         - *parametersWalletId
-      responses:
-        - *responsesListStakePools
-        - *responsesErr404
+      responses: *responsesListStakePools
 
   /stake-pools/{stakePoolId}/wallets/{walletId}:
     put:

From 4ba37cf975d7121cf6d203c04693052672d523a5 Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Tue, 16 Jun 2020 11:04:38 +0200
Subject: [PATCH 14/14] Move shelley LSQ code to Network module

Using a type family to allow jormungandr and haskell implementations to
be different.
---
 lib/core/src/Cardano/Wallet/Network.hs        |  15 ++-
 .../src/Cardano/Pool/Jormungandr/Metrics.hs   |  13 +-
 .../src/Cardano/Wallet/Jormungandr/Network.hs |  11 ++
 .../Cardano/Pool/Jormungandr/MetricsSpec.hs   |   9 +-
 .../Cardano/Pool/Jormungandr/MetricsSpec.hs   |   8 ++
 .../src/Cardano/Wallet/Shelley/Network.hs     |  84 +++++++-----
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 123 +++++-------------
 7 files changed, 128 insertions(+), 135 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index 28beb9f3bcd..666eaef7217 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -17,6 +17,7 @@ module Cardano.Wallet.Network
     , follow
     , FollowAction (..)
     , FollowExit (..)
+    , GetStakeDistribution
 
     -- * Errors
     , ErrNetworkUnavailable (..)
@@ -43,9 +44,7 @@ import Cardano.BM.Data.Tracer
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , ChimericAccount (..)
-    , EpochNo
     , Hash (..)
-    , PoolId (..)
     , ProtocolParameters
     , SealedTx
     , SlotId
@@ -71,8 +70,6 @@ import Control.Tracer
     ( Tracer, traceWith )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
-import Data.Map
-    ( Map )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text
@@ -128,9 +125,7 @@ data NetworkLayer m target block = NetworkLayer
         -- ^ Broadcast a transaction to the chain producer
 
     , stakeDistribution
-        :: EpochNo
-        -> ExceptT ErrNetworkUnavailable m
-            (Map PoolId (Quantity "lovelace" Word64))
+        :: GetStakeDistribution target m
 
     , getAccountBalance
         :: ChimericAccount
@@ -225,6 +220,12 @@ defaultRetryPolicy =
   where
     second = 1000*1000
 
+{-------------------------------------------------------------------------------
+                                 Queries
+-------------------------------------------------------------------------------}
+
+type family GetStakeDistribution target (m :: * -> *) :: *
+
 {-------------------------------------------------------------------------------
                                 Chain Sync
 -------------------------------------------------------------------------------}
diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs
index e58d145ad71..7e79696e683 100644
--- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs
+++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs
@@ -9,6 +9,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | This module can fold over a blockchain to collect metrics about
 -- Stake pools.
@@ -54,12 +55,17 @@ import Cardano.Pool.Jormungandr.Performance
     ( readPoolsPerformances )
 import Cardano.Pool.Jormungandr.Ranking
     ( EpochConstants (..), unsafeMkNonNegative )
+import Cardano.Wallet.Jormungandr.Compatibility
+    ( Jormungandr )
+import Cardano.Wallet.Jormungandr.Network
+    ()
 import Cardano.Wallet.Network
     ( ErrCurrentNodeTip
     , ErrNetworkUnavailable
     , FollowAction (..)
     , FollowExit (..)
     , FollowLog
+    , GetStakeDistribution
     , NetworkLayer (currentNodeTip, stakeDistribution)
     , follow
     )
@@ -163,7 +169,8 @@ data StakePoolLayer e m = StakePoolLayer
 -- The pool productions and stake distrubtions in the db can /never/ be from
 -- different forks such that it's safe for readers to access it.
 monitorStakePools
-    :: Tracer IO StakePoolLog
+    :: GetStakeDistribution t IO ~ GetStakeDistribution Jormungandr IO
+    => Tracer IO StakePoolLog
     -> (Block, Quantity "block" Word32)
         -- ^ Genesis block and 'k'
     -> NetworkLayer IO t Block
@@ -201,7 +208,7 @@ monitorStakePools tr (block0, Quantity k) nl db@DBLayer{..} = do
         distributions <- forM epochs $ \ep -> do
             liftIO $ traceWith tr $ MsgStakeDistribution ep
             withExceptT ErrMonitorStakePoolsNetworkUnavailable $
-                (ep,) <$> stakeDistribution nl ep
+                (ep,) <$> (stakeDistribution nl ep)
 
         currentTip <- withExceptT ErrMonitorStakePoolsCurrentNodeTip $
             currentNodeTip nl
@@ -253,7 +260,7 @@ newStakePoolLayer
     -- ^ Genesis block header
     -> (EpochNo -> Quantity "lovelace" Word64 -> EpochConstants)
     -> DBLayer IO
-    -> NetworkLayer IO t Block
+    -> NetworkLayer IO Jormungandr Block
     -> FilePath
     -- ^ A directory to cache downloaded stake pool metadata. Will be created if
     -- it does not exist.
diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs
index 816866628f7..9f1976f32cd 100644
--- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs
+++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs
@@ -107,6 +107,7 @@ import Cardano.Wallet.Jormungandr.Compatibility
 import Cardano.Wallet.Network
     ( Cursor
     , ErrGetAccountBalance (..)
+    , GetStakeDistribution
     , NetworkLayer (..)
     , NextBlocksResult (..)
     , defaultRetryPolicy
@@ -455,6 +456,16 @@ mkRawNetworkLayer np batchSize st j = NetworkLayer
             _ ->
                 RollBackward $ Cursor emptyBlockHeaders
 
+
+{-------------------------------------------------------------------------------
+                                 Queries
+-------------------------------------------------------------------------------}
+
+type instance GetStakeDistribution Jormungandr m =
+    EpochNo
+    -> ExceptT ErrNetworkUnavailable m
+        (Map PoolId (Quantity "lovelace" Word64))
+
 {-------------------------------------------------------------------------------
                              Jormungandr Cursor
 -------------------------------------------------------------------------------}
diff --git a/lib/jormungandr/test/integration/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/integration/Cardano/Pool/Jormungandr/MetricsSpec.hs
index 9e08e27a8b5..8d2bda63e92 100644
--- a/lib/jormungandr/test/integration/Cardano/Pool/Jormungandr/MetricsSpec.hs
+++ b/lib/jormungandr/test/integration/Cardano/Pool/Jormungandr/MetricsSpec.hs
@@ -11,13 +11,17 @@ import Cardano.BM.Trace
 import Cardano.Pool.DB
     ( DBLayer (..) )
 import Cardano.Pool.Jormungandr.Metrics
-    ( monitorStakePools )
+    ( Block, monitorStakePools )
 import Cardano.Wallet.Jormungandr
     ( toSPBlock )
+import Cardano.Wallet.Jormungandr.Compatibility
+    ( Jormungandr )
 import Cardano.Wallet.Jormungandr.Launch
     ( withConfig )
 import Cardano.Wallet.Jormungandr.Network
     ( JormungandrBackend (..), withJormungandr, withNetworkLayer )
+import Cardano.Wallet.Network
+    ( NetworkLayer )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , GenesisParameters (..)
@@ -109,7 +113,8 @@ spec = around setup $ do
 
     withMonitorStakePoolsThread (block0, k) nl db action = do
         bracket
-            (forkIO $ void $ monitorStakePools nullTracer (block0, k) nl db)
+            (forkIO $ void $ monitorStakePools nullTracer (block0, k)
+                (nl :: NetworkLayer IO Jormungandr Block) db)
             killThread
             action
 
diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs
index 46f2bc03232..672696eaafa 100644
--- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs
+++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs
@@ -39,10 +39,13 @@ import Cardano.Pool.Jormungandr.Metrics
     )
 import Cardano.Pool.Jormungandr.Ranking
     ( EpochConstants (..), unsafeMkNonNegative, unsafeMkPositive )
+import Cardano.Wallet.Jormungandr.Network
+    ()
 import Cardano.Wallet.Network
     ( Cursor
     , ErrGetBlock (..)
     , ErrNetworkUnavailable (..)
+    , GetStakeDistribution
     , NetworkLayer (..)
     , NextBlocksResult (..)
     )
@@ -272,6 +275,11 @@ prop_trackRegistrations test = monadicIO $ do
 
 data instance Cursor RegistrationsTest = Cursor BlockHeader
 
+type instance GetStakeDistribution RegistrationsTest m =
+    EpochNo
+    -> ExceptT ErrNetworkUnavailable m
+        (Map PoolId (Quantity "lovelace" Word64))
+
 test_emptyDatabaseNotSynced :: IO ()
 test_emptyDatabaseNotSynced = do
     setEnv envVarMetadataRegistry "-"
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 415a03ff5ab..0dc08386835 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -26,6 +26,8 @@ module Cardano.Wallet.Shelley.Network
       pattern Cursor
     , withNetworkLayer
 
+    , NodePoolLsqData (..)
+
       -- * Logging
     , NetworkLayerLog (..)
     ) where
@@ -42,6 +44,7 @@ import Cardano.Wallet.Network
     , ErrGetAccountBalance (..)
     , ErrNetworkUnavailable (..)
     , ErrPostTx (..)
+    , GetStakeDistribution
     , NetworkLayer (..)
     , mapCursor
     )
@@ -52,12 +55,16 @@ import Cardano.Wallet.Shelley.Compatibility
     , ShelleyBlock
     , TPraosStandardCrypto
     , fromChainHash
+    , fromNonMyopicMemberRewards
     , fromPParams
+    , fromPoolDistr
     , fromSlotNo
     , fromTip
     , fromTip'
+    , optimumNumberOfPools
     , toGenTx
     , toPoint
+    , toShelleyCoin
     , toStakeCredential
     )
 import Control.Concurrent.Async
@@ -91,7 +98,7 @@ import Control.Monad.Class.MonadTimer
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
-    ( throwE )
+    ( ExceptT (..), throwE, withExceptT )
 import Control.Retry
     ( RetryPolicyM, RetryStatus (..), capDelay, fibonacciBackoff, recovering )
 import Control.Tracer
@@ -104,14 +111,20 @@ import Data.Function
     ( (&) )
 import Data.List
     ( isInfixOf )
+import Data.Map
+    ( Map )
+import Data.Maybe
+    ( fromMaybe )
 import Data.Quantity
-    ( Quantity (..) )
+    ( Percentage, Quantity (..) )
 import Data.Text
     ( Text )
 import Data.Text.Class
     ( ToText (..) )
 import Data.Void
     ( Void )
+import Data.Word
+    ( Word64 )
 import Fmt
     ( pretty )
 import GHC.Stack
@@ -203,7 +216,6 @@ import qualified Shelley.Spec.Ledger.PParams as SL
 data instance Cursor (m Shelley) = Cursor
     (Point ShelleyBlock)
     (TQueue m (ChainSyncCmd ShelleyBlock m))
-    (TQueue m (LocalStateQueryCmd ShelleyBlock m))
 
 -- | Create an instance of the network layer
 withNetworkLayer
@@ -239,7 +251,7 @@ withNetworkLayer tr np addrInfo versionData action = do
             , cursorSlotId = _cursorSlotId
             , getProtocolParameters = atomically $ readTVar protocolParamsVar
             , postTx = _postTx localTxSubmissionQ
-            , stakeDistribution = _stakeDistribution
+            , stakeDistribution = _stakeDistribution queryRewardQ
             , getAccountBalance = _getAccountBalance nodeTipVar queryRewardQ
             }
   where
@@ -268,8 +280,7 @@ withNetworkLayer tr np addrInfo versionData action = do
 
     _initCursor headers = do
         chainSyncQ <- atomically newTQueue
-        stateQueryQ <- atomically newTQueue
-        client <- mkWalletClient tr gp chainSyncQ stateQueryQ
+        client <- mkWalletClient gp chainSyncQ
         let handlers = failOnConnectionLost tr
         link =<< async
             (connectClient tr handlers client versionData addrInfo)
@@ -284,18 +295,18 @@ withNetworkLayer tr np addrInfo versionData action = do
                     $ MsgIntersectionFound
                     $ fromChainHash getGenesisBlockHash
                     $ pointHash intersection
-                pure $ Cursor intersection chainSyncQ stateQueryQ
+                pure $ Cursor intersection chainSyncQ
             _ -> fail $ unwords
                 [ "initCursor: intersection not found? This can't happen"
                 , "because we always give at least the genesis point."
                 , "Here are the points we gave: " <> show headers
                 ]
 
-    _nextBlocks (Cursor _ chainSyncQ lsqQ) = do
-        let toCursor point = Cursor point chainSyncQ lsqQ
+    _nextBlocks (Cursor _ chainSyncQ) = do
+        let toCursor point = Cursor point chainSyncQ
         liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks
 
-    _cursorSlotId (Cursor point _ _) = do
+    _cursorSlotId (Cursor point _) = do
         fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point
 
     _getAccountBalance nodeTipVar queryRewardQ acct = do
@@ -330,8 +341,36 @@ withNetworkLayer tr np addrInfo versionData action = do
             SubmitSuccess -> pure ()
             SubmitFail err -> throwE $ ErrPostTxBadRequest $ T.pack (show err)
 
-    _stakeDistribution =
-        notImplemented "stakeDistribution"
+    handleQueryFailure = withExceptT
+        (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected" ++ show e) . ExceptT
+    _stakeDistribution queue pt coin = do
+        stakeMap <- fromPoolDistr <$> handleQueryFailure
+            (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution)
+        let toStake = Set.singleton $ Left $ toShelleyCoin coin
+        rewardsPerAccount <- fromNonMyopicMemberRewards <$> handleQueryFailure
+            (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake))
+        pparams <- handleQueryFailure
+            (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams)
+
+        let rewardMap = fromMaybe
+                (error "stakeDistribution: requested rewards not included in response")
+                (Map.lookup (Left coin) rewardsPerAccount)
+
+        return $ NodePoolLsqData
+            (optimumNumberOfPools pparams)
+            rewardMap
+            stakeMap
+
+type instance GetStakeDistribution (IO Shelley) m
+    = (Point ShelleyBlock
+   -> W.Coin
+   -> ExceptT ErrNetworkUnavailable m NodePoolLsqData)
+
+data NodePoolLsqData = NodePoolLsqData
+    { nOpt :: Int
+    , rewards :: Map W.PoolId (Quantity "lovelace" Word64)
+    , stake :: Map W.PoolId Percentage
+    }
 
 --------------------------------------------------------------------------------
 --
@@ -358,15 +397,12 @@ type NetworkClient m = OuroborosApplication
 -- purposes of syncing blocks to a single wallet.
 mkWalletClient
     :: (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
-    => Tracer m NetworkLayerLog
-    -> W.GenesisParameters
+    => W.GenesisParameters
         -- ^ Static blockchain parameters
     -> TQueue m (ChainSyncCmd ShelleyBlock m)
         -- ^ Communication channel with the ChainSync client
-    -> TQueue m (LocalStateQueryCmd ShelleyBlock m)
-        -- ^ Communication channel with the local state query
     -> m (NetworkClient m)
-mkWalletClient tr gp chainSyncQ lsqQ = do
+mkWalletClient gp chainSyncQ = do
     stash <- atomically newTQueue
     pure $ nodeToClientProtocols (const $ return $ NodeToClientProtocols
         { localChainSyncProtocol =
@@ -379,14 +415,9 @@ mkWalletClient tr gp chainSyncQ lsqQ = do
             doNothingProtocol
 
         , localStateQueryProtocol =
-            InitiatorProtocolOnly $ MuxPeerRaw
-                $ \channel -> runPeer tr' (cStateQueryCodec codecs) channel
-                $ localStateQueryClientPeer
-                $ localStateQuery lsqQ
+            doNothingProtocol
         })
         NodeToClientV_2
-  where
-    tr' = contramap MsgLocalStateQuery tr
 
 -- | Construct a network client with the given communication channel, for the
 -- purposes of querying delegations and rewards.
@@ -627,13 +658,6 @@ handleMuxError tr onResourceVanished = pure . errorType >=> \case
         traceWith tr Nothing
         pure onResourceVanished
 
---------------------------------------------------------------------------------
---
--- Temporary
-
-notImplemented :: HasCallStack => String -> a
-notImplemented what = error ("Not implemented: " <> what)
-
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 4092d241b64..3482a6e8572 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -16,39 +16,26 @@ module Cardano.Wallet.Shelley.Pools where
 
 import Prelude
 
-import Cardano.Wallet.Api.Server
-    ( LiftHandler (..), apiError )
 import Cardano.Wallet.Api.Types
-    ( ApiErrorCode (..), ApiT (..) )
+    ( ApiT (..) )
 import Cardano.Wallet.Network
-    ( NetworkLayer (..) )
+    ( ErrNetworkUnavailable, NetworkLayer (..) )
 import Cardano.Wallet.Primitive.Types
     ( Coin (..), GenesisParameters (..), PoolId )
 import Cardano.Wallet.Shelley.Compatibility
-    ( Shelley
-    , ShelleyBlock
-    , fromNonMyopicMemberRewards
-    , fromPoolDistr
-    , optimumNumberOfPools
-    , toPoint
-    , toShelleyCoin
-    )
+    ( Shelley, toPoint )
 import Cardano.Wallet.Shelley.Network
-    ( pattern Cursor )
+    ( NodePoolLsqData (..) )
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage, unsafeRunExceptT )
-import Control.Monad.Class.MonadSTM
-    ( MonadSTM, TQueue )
 import Control.Monad.IO.Class
     ( liftIO )
 import Control.Monad.Trans.Except
-    ( ExceptT (..), runExceptT, withExceptT )
+    ( ExceptT (..), runExceptT )
 import Data.Map
     ( Map )
 import Data.Map.Merge.Strict
     ( dropMissing, traverseMissing, zipWithMatched )
-import Data.Maybe
-    ( fromMaybe )
 import Data.Ord
     ( Down (..) )
 import Data.Quantity
@@ -59,18 +46,10 @@ import Data.Word
     ( Word64 )
 import GHC.Generics
     ( Generic )
-import Ouroboros.Network.Block
-    ( Point )
-import Ouroboros.Network.Client.Wallet
-    ( LocalStateQueryCmd (..), send )
-import Servant
-    ( err500 )
 
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified Ouroboros.Consensus.Shelley.Ledger as OC
 
 -- | Stake Pool Data fields fetched from the node via LSQ
 data PoolLsqMetrics = PoolLsqMetrics
@@ -79,61 +58,27 @@ data PoolLsqMetrics = PoolLsqMetrics
     , saturation :: Double
     } deriving (Eq, Show, Generic)
 
-
-data ErrFetchMetrics = ErrFetchMetrics
-  deriving Show
-
--- | Fetches information about pools availible over LSQ from the node, at the
--- nodes' tip.
-fetchLsqPoolMetrics
-    :: MonadSTM m
-    => TQueue m (LocalStateQueryCmd ShelleyBlock m)
-    -> Point ShelleyBlock
-    -> Coin
-    -> ExceptT ErrFetchMetrics m (Map PoolId PoolLsqMetrics)
-fetchLsqPoolMetrics queue pt coin = do
-    stakeMap <- fromPoolDistr <$> handleQueryFailure
-        (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution)
-    let toStake = Set.singleton $ Left $ toShelleyCoin coin
-    rewardsPerAccount <- fromNonMyopicMemberRewards <$> handleQueryFailure
-        (queue `send` CmdQueryLocalState pt (OC.GetNonMyopicMemberRewards toStake))
-    pparams <- handleQueryFailure
-        (queue `send` CmdQueryLocalState pt OC.GetCurrentPParams)
-
-    let rewardMap = fromMaybe
-            (error "askNode: requested rewards not included in response")
-            (Map.lookup (Left coin) rewardsPerAccount)
-
-    return $ combine
-        (optimumNumberOfPools pparams)
-        stakeMap
-        rewardMap
+combineLsqData
+    :: NodePoolLsqData
+    -> Map PoolId PoolLsqMetrics
+combineLsqData NodePoolLsqData{nOpt, rewards, stake} =
+    Map.merge stakeButNoRewards rewardsButNoStake bothPresent stake rewards
   where
-    handleQueryFailure = withExceptT (const ErrFetchMetrics) . ExceptT
-
-    combine
-        :: Int -- ^ Desired number of pools
-        -> Map PoolId Percentage
-        -> Map PoolId (Quantity "lovelace" Word64)
-        -> Map PoolId PoolLsqMetrics
-    combine nOpt =
-        Map.merge stakeButNoRewards rewardsButNoStake bothPresent
-      where
-        -- calculate the saturation from the relative stake
-        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
-        -- to 0 here:
-        stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
-            { nonMyopicMemberRewards = Quantity 0
-            , relativeStake = s
-            , saturation = (sat s)
-            }
+    -- calculate the saturation from the relative stake
+    sat s = fromRational $ (getPercentage s) / (1 / fromIntegral nOpt)
 
-        rewardsButNoStake = dropMissing
+    -- 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
+    -- to 0 here:
+    stakeButNoRewards = traverseMissing $ \_k s -> pure $ PoolLsqMetrics
+        { nonMyopicMemberRewards = Quantity 0
+        , relativeStake = s
+        , saturation = (sat s)
+        }
 
-        bothPresent       = zipWithMatched  $ \_k s r -> PoolLsqMetrics r s (sat s)
+    rewardsButNoStake = dropMissing
+
+    bothPresent       = zipWithMatched  $ \_k s r -> PoolLsqMetrics r s (sat s)
 
 readBlockProductions :: IO (Map PoolId Int)
 readBlockProductions = return Map.empty
@@ -142,19 +87,11 @@ readBlockProductions = return Map.empty
 -- Api Server Handler
 --
 
-instance LiftHandler ErrFetchMetrics where
-    handler = \case
-        ErrFetchMetrics ->
-            apiError err500 NotSynced $ mconcat
-                [ "There was a problem fetching metrics from the node."
-                ]
-
 data StakePoolLayer = StakePoolLayer
     { knownPools :: IO [PoolId]
-    , listStakePools :: Coin -> ExceptT ErrFetchMetrics IO [Api.ApiStakePool]
+    , listStakePools :: Coin -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
     }
 
-
 newStakePoolLayer
     :: GenesisParameters
     -> NetworkLayer IO (IO Shelley) b
@@ -174,10 +111,9 @@ newStakePoolLayer gp nl = StakePoolLayer
     _knownPools
         :: IO [PoolId]
     _knownPools = do
-        Cursor _workerTip _ lsqQ <- initCursor nl []
         pt <- getTip
         res <- runExceptT $ map fst . Map.toList
-            <$> fetchLsqPoolMetrics lsqQ pt dummyCoin
+            . combineLsqData <$> stakeDistribution nl pt dummyCoin
         case res of
             Right x -> return x
             Left _e -> return []
@@ -187,13 +123,14 @@ newStakePoolLayer gp nl = StakePoolLayer
         :: Coin
         -- ^ The amount of stake the user intends to delegate, which may affect the
         -- ranking of the pools.
-        -> ExceptT ErrFetchMetrics IO [Api.ApiStakePool]
+        -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool]
     _listPools s = do
-            Cursor _workerTip _ lsqQ <- liftIO $ initCursor nl []
             pt <- liftIO getTip
             map mkApiPool
                 . sortOn (Down . nonMyopicMemberRewards . snd)
-                . Map.toList <$> fetchLsqPoolMetrics lsqQ pt s
+                . Map.toList
+                . combineLsqData
+                <$> stakeDistribution nl pt s
       where
         mkApiPool (pid, PoolLsqMetrics prew pstk psat) = Api.ApiStakePool
             { Api.id = (ApiT pid)