Use and combine chain data with LSQ data for stake pools

lib/core-integration/cardano-wallet-core-integration.cabal

@@ -55,7 +55,6 @@ library
     , http-types
     , memory
     , process
-    , QuickCheck
     , retry
     , scrypt
     , template-haskell

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

@@ -26,15 +26,27 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.AddressDerivation.Shelley
     ( ShelleyKey )
 import Cardano.Wallet.Primitive.Types
-    ( Coin (..), Direction (..), PoolId (..), TxStatus (..) )
+    ( Coin (..)
+    , Direction (..)
+    , PoolId (..)
+    , StakePoolMetadata (..)
+    , StakePoolTicker (..)
+    , TxStatus (..)
+    )
+import Cardano.Wallet.Unsafe
+    ( unsafeMkPercentage )
 import Data.Generics.Internal.VL.Lens
     ( view, (^.) )
+import Data.List
+    ( sortOn )
+import Data.Maybe
+    ( mapMaybe )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Text.Class
     ( toText )
 import Test.Hspec
-    ( SpecWith, describe, it, shouldBe, xit )
+    ( SpecWith, describe, it, shouldBe, shouldSatisfy, xit )
 import Test.Integration.Framework.DSL
     ( Context (..)
     , Headers (..)
@@ -65,7 +77,6 @@ import Test.Integration.Framework.DSL
     , walletId
     , (.<=)
     , (.>)
-    , (.>=)
     )
 import Test.Integration.Framework.TestData
     ( errMsg403DelegationFee
@@ -415,70 +426,104 @@ spec = do
             , expectErrorMessage $ errMsg403DelegationFee fee
             ]
 
-    it "STAKE_POOLS_LIST_01 - List stake pools" $ \ctx -> do
-        eventually "Listing stake pools shows expected information" $ do
-            r <- request @[ApiStakePool] ctx
-                (Link.listStakePools arbitraryStake) Default Empty
+    let listPools ctx = request @[ApiStakePool] @IO ctx (Link.listStakePools arbitraryStake) Default Empty
+    describe "STAKE_POOLS_LIST_01 - List stake pools" $ do
+        it "immediately has non-zero saturation & stake" $ \ctx -> do
+            r <- listPools ctx
             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))
-
+                -- At the time of setup, the pools have 1/3 stake each, but
+                -- this could potentially be changed by other tests. Hence,
+                -- we try to be forgiving here.
                 , expectListField 0
-                    #cost (`shouldBe` (Quantity 0))
+                    (#metrics . #relativeStake)
+                        (.> Quantity (unsafeMkPercentage 0))
                 , expectListField 1
-                    #cost (`shouldBe` (Quantity 0))
+                    (#metrics . #relativeStake)
+                        (.> Quantity (unsafeMkPercentage 0))
                 , expectListField 2
-                    #cost (`shouldBe` (Quantity 0))
+                    (#metrics . #relativeStake)
+                        (.> Quantity (unsafeMkPercentage 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)
+        it "eventually has correct margin and cost" $ \ctx -> do
+            eventually "pool worker finds the certificate" $ do
+                r <- listPools ctx
+                expectResponseCode HTTP.status200 r
+                verify r
+                    [ expectListField 0
+                        (#cost) (`shouldBe` Just (Quantity 0))
+                    , expectListField 1
+                        (#cost) (`shouldBe` Just (Quantity 0))
+                    , expectListField 2
+                        (#cost) (`shouldBe` Just (Quantity 0))
+
+                    , expectListField 0
+                        #margin (`shouldBe` Just
+                            (Quantity $ unsafeMkPercentage 0.1 ))
+                    , expectListField 1
+                        #margin (`shouldBe` Just
+                            (Quantity $ unsafeMkPercentage 0.1 ))
+                    , expectListField 2
+                        #margin (`shouldBe` Just
+                            (Quantity $ unsafeMkPercentage 0.1 ))
+                    -- TODO: Test that we have non-zero non-myopic member
+                    -- rewards, and sort by it.
+                    ]
 
-                , expectListField 0
-                    (#metrics . #saturation) (.>= 0)
-                , expectListField 1
-                    (#metrics . #saturation) (.>= 0)
-                , expectListField 2
-                    (#metrics . #saturation) (.>= 0)
-                ]
+        it "at least one pool eventually produces block" $ \ctx -> do
+            eventually "eventually produces block" $ do
+                (_, Right r) <- listPools ctx
+                let production = sum $
+                        getQuantity . view (#metrics . #producedBlocks) <$> r
+                let saturation =
+                        view (#metrics . #saturation) <$> r
+
+                production `shouldSatisfy` (> 0)
+                saturation `shouldSatisfy` (any (> 0))
+
+        it "contains pool metadata" $ \ctx -> do
+            eventually "metadata is fetched" $ do
+                r <- listPools ctx
+                let metadataList =
+                        [ StakePoolMetadata
+                            { ticker = (StakePoolTicker "GPA")
+                            , name = "Genesis Pool A"
+                            , description = Nothing
+                            , homepage = "https://iohk.io"
+                            }
+                        , StakePoolMetadata
+                            { ticker = (StakePoolTicker "GPB")
+                            , name = "Genesis Pool B"
+                            , description = Nothing
+                            , homepage = "https://iohk.io"
+                            }
+                        , StakePoolMetadata
+                            { ticker = (StakePoolTicker "GPC")
+                            , name = "Genesis Pool C"
+                            , description = Just "Lorem Ipsum Dolor Sit Amet."
+                            , homepage = "https://iohk.io"
+                            }
+                        ]
+
+                verify r
+                    [ expectListSize 3
+                    , expectField id $ \pools ->
+                        -- To ignore the arbitrary order,
+                        -- we sort on the names before comparing
+                        sortOn name ( mapMaybe (fmap getApiT . view #metadata) pools)
+                        `shouldBe` metadataList
+                    ]
 
     it "STAKE_POOLS_LIST_05 - Fails without query parameter" $ \ctx -> do
-        _w <- fixtureWallet ctx -- Ambiguous type error without this line
-        r <- request @[ApiStakePool] ctx
+        r <- request @[ApiStakePool] @IO ctx
             (Link.listStakePools Nothing) Default Empty
         expectResponseCode HTTP.status400 r
 
     it "STAKE_POOLS_LIST_06 - NonMyopicMemberRewards are 0 when stake is 0" $ \ctx -> do
-        _w <- fixtureWallet ctx
         let stake = Just $ Coin 0
-        r <- request @[ApiStakePool] ctx (Link.listStakePools stake) Default Empty
+        r <- request @[ApiStakePool] @IO ctx (Link.listStakePools stake) Default Empty
         expectResponseCode HTTP.status200 r
         verify r
             [ expectListSize 3

lib/core/src/Cardano/DB/Sqlite.hs

@@ -364,6 +364,7 @@ data DBLog
     | MsgRun Bool
     | MsgConnStr Text
     | MsgClosing (Maybe FilePath)
+    | MsgWillOpenDB (Maybe FilePath)
     | MsgDatabaseReset
     | MsgIsAlreadyClosed Text
     | MsgStatementAlreadyFinalized Text
@@ -439,6 +440,7 @@ instance HasSeverityAnnotation DBLog where
         MsgRun _ -> Debug
         MsgConnStr _ -> Debug
         MsgClosing _ -> Debug
+        MsgWillOpenDB _ -> Info
         MsgDatabaseReset -> Notice
         MsgIsAlreadyClosed _ -> Warning
         MsgStatementAlreadyFinalized _ -> Warning
@@ -463,6 +465,7 @@ instance ToText DBLog where
         MsgQuery stmt _ -> stmt
         MsgRun False -> "Running database action - Start"
         MsgRun True -> "Running database action - Finish"
+        MsgWillOpenDB fp -> "Will open db at " <> (maybe "in-memory" T.pack fp)
         MsgConnStr connStr -> "Using connection string: " <> connStr
         MsgClosing fp -> "Closing database ("+|fromMaybe "in-memory" fp|+")"
         MsgDatabaseReset ->

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

@@ -135,6 +135,9 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm ()
         -- ^ Store metadata fetched from a remote server.
 
+    , readPoolMetadata
+        :: stm (Map StakePoolMetadataHash StakePoolMetadata)
+
     , readSystemSeed
         :: stm StdGen
         -- ^ Read the seed assigned to this particular database. The seed is

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

@@ -30,6 +30,7 @@ import Cardano.Pool.DB.Model
     , mPutPoolRegistration
     , mPutStakeDistribution
     , mReadCursor
+    , mReadPoolMetadata
     , mReadPoolProduction
     , mReadPoolRegistration
     , mReadStakeDistribution
@@ -101,6 +102,8 @@ newDBLayer = do
         , cleanDB =
             void $ alterPoolDB (const Nothing) db mCleanPoolProduction
 
+        , readPoolMetadata = readPoolDB db mReadPoolMetadata
+
         , atomically = id
         }
 

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

@@ -37,6 +37,7 @@ module Cardano.Pool.DB.Model
     , mReadTotalProduction
     , mPutStakeDistribution
     , mReadStakeDistribution
+    , mReadPoolMetadata
     , mPutPoolRegistration
     , mReadPoolRegistration
     , mUnfetchedPoolMetadataRefs
@@ -228,6 +229,10 @@ mPutPoolMetadata _ hash meta db@PoolDatabase{metadata} =
     , db { metadata = Map.insert hash meta metadata }
     )
 
+mReadPoolMetadata
+    :: ModelPoolOp (Map StakePoolMetadataHash StakePoolMetadata)
+mReadPoolMetadata db@PoolDatabase{metadata} = (Right metadata, db)
+
 mReadSystemSeed
     :: PoolDatabase
     -> IO (StdGen, PoolDatabase)

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -50,6 +51,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolRegistrationCertificate (..)
     , SlotId (..)
     , StakePoolMetadata (..)
+    , StakePoolMetadataHash
     )
 import Cardano.Wallet.Unsafe
     ( unsafeMkPercentage )
@@ -127,7 +129,8 @@ withDBLayer
     -> (DBLayer IO -> IO a)
        -- ^ Action to run.
     -> IO a
-withDBLayer trace fp action =
+withDBLayer trace fp action = do
+    traceWith trace (MsgWillOpenDB fp)
     bracket before after (action . snd)
   where
     before = newDBLayer trace fp
@@ -274,6 +277,10 @@ newDBLayer trace fp = do
             let StakePoolMetadata{ticker,name,description,homepage} = metadata
             putMany [PoolMetadata hash poolId name ticker description homepage]
 
+        , readPoolMetadata = do
+            Map.fromList . map (fromPoolMeta . entityVal)
+                <$> selectList [] []
+
         , listRegisteredPools = do
             fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ]
                 [ Desc PoolRegistrationSlot ]
@@ -391,3 +398,14 @@ fromStakeDistribution distribution =
     ( stakeDistributionPoolId distribution
     , Quantity (stakeDistributionStake distribution)
     )
+
+fromPoolMeta
+    :: PoolMetadata
+    -> (StakePoolMetadataHash, StakePoolMetadata)
+fromPoolMeta meta = (poolMetadataHash meta,) $
+    StakePoolMetadata
+        { ticker = poolMetadataTicker meta
+        , name = poolMetadataName meta
+        , description = poolMetadataDescription meta
+        , homepage = poolMetadataHomepage meta
+        }

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

@@ -393,8 +393,8 @@ data ApiStakePool = ApiStakePool
     { id :: !(ApiT PoolId)
     , metrics :: !ApiStakePoolMetrics
     , metadata :: !(Maybe (ApiT StakePoolMetadata))
-    , cost :: !(Quantity "lovelace" Natural)
-    , margin :: !(Quantity "percent" Percentage)
+    , cost :: !(Maybe (Quantity "lovelace" Natural))
+    , margin :: !(Maybe (Quantity "percent" Percentage))
     } deriving (Eq, Generic, Show)
 
 data ApiStakePoolMetrics = ApiStakePoolMetrics

lib/shelley/cardano-wallet-shelley.cabal

@@ -71,7 +71,6 @@ library
     , retry
     , servant-server
     , shelley-spec-ledger
-    , sort
     , temporary
     , text
     , text-class

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

@@ -235,12 +235,12 @@ serveWallet
         withNetworkLayer networkTracer np socketPath vData $ \nl -> do
             withWalletNtpClient io ntpClientTracer $ \ntpClient -> do
                 let pm = fromNetworkMagic $ networkMagic $ fst vData
-                let el = getEpochLength $ genesisParameters np
+                let gp = genesisParameters np
+                let el = getEpochLength gp
                 randomApi <- apiLayer (newTransactionLayer proxy pm el) nl
                 icarusApi  <- apiLayer (newTransactionLayer proxy pm el ) nl
                 shelleyApi <- apiLayer (newTransactionLayer proxy pm el) nl
-                let spl = newStakePoolLayer (genesisParameters np) nl
-                withPoolsMonitoring databaseDir (genesisParameters np) nl $ do
+                withPoolsMonitoring databaseDir gp nl $ \spl -> do
                     startServer
                         proxy
                         socket
@@ -286,14 +286,15 @@ serveWallet
         :: Maybe FilePath
         -> GenesisParameters
         -> NetworkLayer IO t ShelleyBlock
-        -> IO a
+        -> (StakePoolLayer -> IO a)
         -> IO a
     withPoolsMonitoring dir gp nl action =
         Pool.withDBLayer poolsDbTracer (Pool.defaultFilePath <$> dir) $ \db -> do
+            let spl = newStakePoolLayer (genesisParameters np) nl db
             void $ forkFinally (monitorStakePools tr gp nl db) onExit
             fetch <- fetchFromRemote <$> newManager defaultManagerSettings
             void $ forkFinally (monitorMetadata tr gp fetch db) onExit
-            action
+            action spl
       where
         tr = contramap (MsgFromWorker mempty) poolsEngineTracer
         onExit = defaultWorkerAfter poolsEngineTracer