From 3cd052e6845eeaa995948c3c7fcf4646188e66e2 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Tue, 16 Jun 2020 16:17:30 +0200 Subject: [PATCH 1/9] Add Shelley `MsgFetchedNodePoolLsqData` trace --- .../src/Cardano/Wallet/Shelley/Network.hs | 25 ++++++++++++++----- 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index 4175a527955..1011e947460 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -128,7 +128,7 @@ import Data.Void import Data.Word ( Word64 ) import Fmt - ( pretty ) + ( Buildable (..), listF', mapF, pretty ) import GHC.Stack ( HasCallStack ) import Network.Mux @@ -369,10 +369,12 @@ withNetworkLayer tr np addrInfo versionData action = do (error "stakeDistribution: requested rewards not included in response") (Map.lookup (Left coin) rewardsPerAccount) - return $ NodePoolLsqData - (optimumNumberOfPools pparams) - rewardMap - stakeMap + let res = NodePoolLsqData + (optimumNumberOfPools pparams) + rewardMap + stakeMap + liftIO $ traceWith tr $ MsgFetchedNodePoolLsqData res + return res type instance GetStakeDistribution (IO Shelley) m = (Point ShelleyBlock @@ -383,7 +385,14 @@ data NodePoolLsqData = NodePoolLsqData { nOpt :: Int , rewards :: Map W.PoolId (Quantity "lovelace" Word64) , stake :: Map W.PoolId Percentage - } + } deriving (Show, Eq) + +instance Buildable NodePoolLsqData where + build NodePoolLsqData{nOpt,rewards,stake} = listF' id + [ "Stake: " <> mapF (Map.toList stake) + , "Non-myopic member rewards: " <> mapF (Map.toList rewards) + , "Optimum number of pools: " <> pretty nOpt + ] -------------------------------------------------------------------------------- -- @@ -697,6 +706,7 @@ data NetworkLayerLog | MsgAccountDelegationAndRewards W.ChimericAccount Delegations RewardAccounts | MsgDestroyCursor ThreadId + | MsgFetchedNodePoolLsqData NodePoolLsqData data QueryClientName = TipSyncClient @@ -764,6 +774,8 @@ instance ToText NetworkLayerLog where [ "Destroying cursor connection at" , T.pack (show threadId) ] + MsgFetchedNodePoolLsqData d -> + "Fetched pool data from node tip using LSQ: " <> pretty d instance HasPrivacyAnnotation NetworkLayerLog instance HasSeverityAnnotation NetworkLayerLog where @@ -785,3 +797,4 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgGetRewardAccountBalance{} -> Info MsgAccountDelegationAndRewards{} -> Info MsgDestroyCursor{} -> Notice + MsgFetchedNodePoolLsqData{} -> Info From d89814d80c1d031be44719979dcab2aec02e4cfa Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 18 Jun 2020 20:23:51 +0200 Subject: [PATCH 2/9] Allow pool cost and margin to be ommitted in swagger.yaml If their pool registration hasn't been found yet the fields will be left out from the response. --- specifications/api/swagger.yaml | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index aebc2167985..f9aeb504290 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -579,17 +579,32 @@ x-jormungandrStakePoolMetadata: &jormungandrStakePoolMetadata format: bech32 example: addr1sjck9mdmfyhzvjhydcjllgj9vjvl522w0573ncustrrr2rg7h9azg4cyqd36yyd48t5ut72hgld0fg2xfvz82xgwh7wal6g2xt8n996s3xvu5g -x-stakePoolCost: &stakePoolCost +x-jormungandrStakePoolCost: &jormungandrStakePoolCost <<: *amount description: | Estimated cost set by the pool operator when registering his pool. This fixed cost is taken from each reward earned by the pool before splitting rewards between stakeholders. -x-stakePoolMargin: &stakePoolMargin +x-jormungandrStakePoolMargin: &jormungandrStakePoolMargin <<: *percentage description: | Variable margin on the total reward given to an operator before splitting rewards between stakeholders. +x-stakePoolCost: &stakePoolCost + <<: *jormungandrStakePoolCost + description: | + Estimated cost set by the pool operator when registering his pool. + This fixed cost is taken from each reward earned by the pool before splitting rewards between stakeholders. + + May be ommitted if the wallet hasn't found the pool's registration cerificate yet. + +x-stakePoolMargin: &stakePoolMargin + <<: *jormungandrStakePoolMargin + description: | + Variable margin on the total reward given to an operator before splitting rewards between stakeholders. + + May be ommitted if the wallet hasn't found the pool's registration cerificate yet. + x-stakePoolSaturation: &stakePoolSaturation type: number minimum: 0 @@ -811,8 +826,7 @@ components: type: object required: - id - - cost - - margin + - metrics properties: id: *stakePoolId metrics: *stakePoolMetrics @@ -834,8 +848,8 @@ components: id: *stakePoolId metrics: *jormungandrStakePoolMetrics apparent_performance: *stakePoolApparentPerformance - cost: *stakePoolCost - margin: *stakePoolMargin + cost: *jormungandrStakePoolCost + margin: *jormungandrStakePoolMargin metadata: *jormungandrStakePoolMetadata saturation: *stakePoolSaturation desirability: *stakePoolDesirability From 791ce5d725426633413eb0282555fb26e43e27fb Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Thu, 18 Jun 2020 20:23:55 +0200 Subject: [PATCH 3/9] Add readPoolMetadata DB function --- lib/core/src/Cardano/Pool/DB/MVar.hs | 3 +++ lib/core/src/Cardano/Pool/DB/Model.hs | 5 +++++ lib/core/src/Cardano/Pool/DB/Sqlite.hs | 17 +++++++++++++++++ 3 files changed, 25 insertions(+) diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index cdf630665b5..47eedd886e0 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/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 } diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index b7ed469944a..7fe66b12779 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/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) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 5956c5eeb58..2b6871c8bd7 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/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 ) @@ -274,6 +276,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 +397,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 + } From 0074cff2b2fd1ce71714e2224870bad48be87f8d Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Tue, 16 Jun 2020 16:36:03 +0200 Subject: [PATCH 4/9] Read and combine DB data with LSQ when listing pools We already have the workers to pool registration certificates and metadata in the data in the DB. Here we read it. - Ignore blocks produced by BFT nodes - Relocate functions and add documentation - Use strategy `chainButNoLsq = dropMissing` - Check that pools produce blocks - fixup: combineDBAndLsqData -> combineDbAndLsqData - fixup: rewrite fetching of certMap --- .../cardano-wallet-core-integration.cabal | 1 - .../Scenario/API/Shelley/StakePools.hs | 144 +++++++---- lib/core/src/Cardano/Pool/DB.hs | 3 + lib/core/src/Cardano/Wallet/Api/Types.hs | 4 +- lib/shelley/cardano-wallet-shelley.cabal | 1 - lib/shelley/src/Cardano/Wallet/Shelley.hs | 11 +- .../src/Cardano/Wallet/Shelley/Pools.hs | 244 +++++++++++++----- .../data/cardano-node-shelley/genesis.yaml | 2 +- .../cardano-wallet-core-integration.nix | 1 - nix/.stack.nix/cardano-wallet-shelley.nix | 1 - 10 files changed, 284 insertions(+), 128 deletions(-) diff --git a/lib/core-integration/cardano-wallet-core-integration.cabal b/lib/core-integration/cardano-wallet-core-integration.cabal index c1c3141445d..494d776be88 100644 --- a/lib/core-integration/cardano-wallet-core-integration.cabal +++ b/lib/core-integration/cardano-wallet-core-integration.cabal @@ -55,7 +55,6 @@ library , http-types , memory , process - , QuickCheck , retry , scrypt , template-haskell 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 182f5eba94d..684ffa6c159 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 @@ -26,9 +26,21 @@ 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 @@ -65,7 +77,6 @@ import Test.Integration.Framework.DSL , walletId , (.<=) , (.>) - , (.>=) ) import Test.Integration.Framework.TestData ( errMsg403DelegationFee @@ -415,68 +426,107 @@ 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 fixTypeInference = True `shouldBe` True + 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)) - - , expectListField 0 - #cost (`shouldBe` (Quantity 0)) - , expectListField 1 - #cost (`shouldBe` (Quantity 0)) - , expectListField 2 - #cost (`shouldBe` (Quantity 0)) - + -- 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 - #margin (`shouldBe` (Quantity minBound)) + (#metrics . #relativeStake) + (.> Quantity (unsafeMkPercentage 0)) , expectListField 1 - #margin (`shouldBe` (Quantity minBound)) + (#metrics . #relativeStake) + (.> Quantity (unsafeMkPercentage 0)) , 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) - + (#metrics . #relativeStake) + (.> Quantity (unsafeMkPercentage 0)) , expectListField 0 - (#metrics . #saturation) (.>= 0) + (#metrics . #saturation) (.> 0) , expectListField 1 - (#metrics . #saturation) (.>= 0) + (#metrics . #saturation) (.> 0) , expectListField 2 - (#metrics . #saturation) (.>= 0) + (#metrics . #saturation) (.> 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 )) + + , expectListField 0 + (#metrics . #producedBlocks) (.> Quantity 0) + , expectListField 1 + (#metrics . #producedBlocks) (.> Quantity 0) + , expectListField 2 + (#metrics . #producedBlocks) (.> Quantity 0) + -- TODO: Test that we have non-zero non-myopic member + -- rewards, and sort by it. + ] + + 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 + fixTypeInference r <- request @[ApiStakePool] 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 + fixTypeInference let stake = Just $ Coin 0 r <- request @[ApiStakePool] ctx (Link.listStakePools stake) Default Empty expectResponseCode HTTP.status200 r diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index d0925ab79ec..ceb65b91160 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 45c3cfef7f0..41d81303d74 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/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 diff --git a/lib/shelley/cardano-wallet-shelley.cabal b/lib/shelley/cardano-wallet-shelley.cabal index 8b8633c18ac..8033ee99fb2 100644 --- a/lib/shelley/cardano-wallet-shelley.cabal +++ b/lib/shelley/cardano-wallet-shelley.cabal @@ -71,7 +71,6 @@ library , retry , servant-server , shelley-spec-ledger - , sort , temporary , text , text-class diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 9f2fed73c02..64f103267f9 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/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 diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 11eb6e1fa1c..aab4a9121ef 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -3,6 +3,8 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} @@ -11,9 +13,18 @@ -- 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 +-- This module provides tools to collect a consistent view of stake pool data, +-- as provided through @StakePoolLayer@. +module Cardano.Wallet.Shelley.Pools + ( StakePoolLayer (..) + , newStakePoolLayer + , monitorStakePools + , monitorMetadata + + -- * Logs + , StakePoolLog (..) + ) + where import Prelude @@ -58,7 +69,7 @@ import Cardano.Wallet.Shelley.Compatibility import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) import Cardano.Wallet.Unsafe - ( unsafeMkPercentage, unsafeRunExceptT ) + ( unsafeRunExceptT ) import Control.Concurrent ( threadDelay ) import Control.Monad @@ -69,6 +80,8 @@ import Control.Monad.Trans.Except ( ExceptT (..), runExceptT ) import Control.Tracer ( Tracer, contramap, traceWith ) +import Data.Generics.Internal.VL.Lens + ( view ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Map @@ -97,13 +110,129 @@ import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import qualified Data.Text as T --- | Stake Pool Data fields fetched from the node via LSQ +-- +-- Stake Pool Layer +-- + +data StakePoolLayer = StakePoolLayer + { knownPools + :: IO [PoolId] + + -- | List pools based given the the amount of stake the user intends to + -- delegate, which affects the size of the rewards and the ranking of the + -- pools. + , listStakePools + :: Coin + -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] + } + +newStakePoolLayer + :: GenesisParameters + -> NetworkLayer IO (IO Shelley) b + -> DBLayer IO + -> StakePoolLayer +newStakePoolLayer gp nl db = StakePoolLayer + { knownPools = _knownPools + , listStakePools = _listPools + } + where + _knownPools + :: IO [PoolId] + _knownPools = do + tip <- getTip + let dummyCoin = Coin 0 + res <- runExceptT $ map fst . Map.toList + . combineLsqData <$> stakeDistribution nl tip dummyCoin + case res of + Right x -> return x + Left _e -> return [] + + _listPools + :: Coin + -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] + _listPools userStake = do + tip <- liftIO getTip + lsqData <- combineLsqData <$> stakeDistribution nl tip userStake + chainData <- liftIO $ readDBPoolData db + return + . sortOn (Down . (view (#metrics . #nonMyopicMemberRewards))) + . map snd + . Map.toList + $ combineDbAndLsqData lsqData chainData + + -- Note: We shouldn't have to do this conversion. + el = getEpochLength gp + gh = getGenesisBlockHash gp + getTip = fmap (toPoint gh el) . liftIO $ unsafeRunExceptT $ currentNodeTip nl + +-- +-- Data Combination functions +-- +-- + +-- | Stake Pool data fields that we can fetch from the node over Local State +-- Query. data PoolLsqMetrics = PoolLsqMetrics { nonMyopicMemberRewards :: Quantity "lovelace" Word64 , relativeStake :: Percentage , saturation :: Double } deriving (Eq, Show, Generic) +-- | Stake Pool data fields that we read from the DB. +data PoolDBMetrics = PoolDBMetrics + { regCert :: PoolRegistrationCertificate + , nProducedBlocks :: Quantity "block" Word64 + , metadata :: Maybe StakePoolMetadata + } + +-- | Top level combine-function that merges DB and LSQ data. +combineDbAndLsqData + :: Map PoolId PoolLsqMetrics + -> Map PoolId PoolDBMetrics + -> Map PoolId Api.ApiStakePool +combineDbAndLsqData = + Map.merge lsqButNoChain chainButNoLsq bothPresent + where + lsqButNoChain = traverseMissing $ \k lsq -> pure $ mkApiPool k lsq Nothing + + -- In case our chain following has missed a retirement certificate, we + -- treat the lsq data as the source of truth, and dropMissing here. + chainButNoLsq = dropMissing + + bothPresent = zipWithMatched $ \k lsq chain -> mkApiPool k lsq (Just chain) + + mkApiPool + :: PoolId + -> PoolLsqMetrics + -> Maybe PoolDBMetrics + -> Api.ApiStakePool + mkApiPool + pid + (PoolLsqMetrics prew pstk psat) + dbData + = Api.ApiStakePool + { Api.id = (ApiT pid) + , Api.metrics = Api.ApiStakePoolMetrics + { Api.nonMyopicMemberRewards = mapQ fromIntegral prew + , Api.relativeStake = Quantity pstk + , Api.saturation = psat + , Api.producedBlocks = maybe (Quantity 0) + (mapQ fromIntegral . nProducedBlocks) dbData + } + , Api.metadata = dbData >>= metadata >>= (return . ApiT) + , Api.cost = mapQ fromIntegral . poolCost . regCert <$> dbData + , Api.margin = Quantity . poolMargin . regCert <$> dbData + } + + mapQ f (Quantity x) = Quantity $ f x + +-- | Combines all the LSQ data into a single map. +-- +-- This is the data we can ask the node for the most recent version of, over the +-- local state query protocol. +-- +-- Calculating e.g. the nonMyopicMemberRewards ourselves through chain-following +-- would be completely impractical. combineLsqData :: NodePoolLsqData -> Map PoolId PoolLsqMetrics @@ -122,77 +251,54 @@ combineLsqData NodePoolLsqData{nOpt, rewards, stake} = , saturation = (sat s) } - rewardsButNoStake = dropMissing + rewardsButNoStake = traverseMissing $ \k r -> + error $ "Rewards but no stake: " <> show (k, r) bothPresent = zipWithMatched $ \_k s r -> PoolLsqMetrics r s (sat s) -readBlockProductions :: IO (Map PoolId Int) -readBlockProductions = return Map.empty - --- --- Api Server Handler --- - -data StakePoolLayer = StakePoolLayer - { knownPools :: IO [PoolId] - , listStakePools :: Coin -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] - } - -newStakePoolLayer - :: GenesisParameters - -> NetworkLayer IO (IO Shelley) b - -> StakePoolLayer -newStakePoolLayer gp nl = StakePoolLayer - { knownPools = _knownPools - , listStakePools = _listPools - } +-- | Combines all the chain-following data into a single map +-- (doesn't include metadata) +combineChainData + :: Map PoolId PoolRegistrationCertificate + -> Map PoolId (Quantity "block" Word64) + -> Map PoolId + (PoolRegistrationCertificate, Quantity "block" Word64) +combineChainData = + Map.merge registeredNoProductions notRegisteredButProducing bothPresent 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 - pt <- getTip - res <- runExceptT $ map fst . Map.toList - . combineLsqData <$> stakeDistribution nl pt dummyCoin - case res of - Right x -> return x - Left _e -> return [] + registeredNoProductions = traverseMissing $ \_k cert -> + pure (cert, Quantity 0) + -- Ignore blocks produced by BFT nodes. + notRegisteredButProducing = dropMissing - _listPools - :: Coin - -- ^ The amount of stake the user intends to delegate, which may affect the - -- ranking of the pools. - -> ExceptT ErrNetworkUnavailable IO [Api.ApiStakePool] - _listPools s = do - pt <- liftIO getTip - map mkApiPool - . sortOn (Down . nonMyopicMemberRewards . snd) - . Map.toList - . combineLsqData - <$> stakeDistribution nl 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 + bothPresent = zipWithMatched $ const (,) +-- NOTE: If performance becomes a problem, we could try replacing all +-- the individual DB queries, and combbination functions with a single +-- hand-written Sqlite query. +readDBPoolData + :: DBLayer IO + -> IO (Map PoolId PoolDBMetrics) +readDBPoolData DBLayer{..} = atomically $ do + pools <- listRegisteredPools + registrations <- mapM readPoolRegistration pools + let certMap = Map.fromList + [(poolId, cert) | (poolId, Just cert) <- zip pools registrations] + prodMap <- readTotalProduction + metaMap <- readPoolMetadata + return $ Map.map (lookupMetaIn metaMap) (combineChainData certMap prodMap) + where + lookupMetaIn + :: Map StakePoolMetadataHash StakePoolMetadata + -> (PoolRegistrationCertificate, Quantity "block" Word64) + -> PoolDBMetrics + lookupMetaIn m (cert, n) = + let + metaHash = snd <$> poolMetadata cert + meta = flip Map.lookup m =<< metaHash + in + PoolDBMetrics cert n meta -- -- Monitoring stake pool diff --git a/lib/shelley/test/data/cardano-node-shelley/genesis.yaml b/lib/shelley/test/data/cardano-node-shelley/genesis.yaml index 5e2452b0e24..b5fb1745391 100644 --- a/lib/shelley/test/data/cardano-node-shelley/genesis.yaml +++ b/lib/shelley/test/data/cardano-node-shelley/genesis.yaml @@ -6,7 +6,7 @@ protocolParams: protocolVersion: minor: 0 major: 0 - decentralisationParam: 0.97 # means 3% decentralised + decentralisationParam: 0.1 # means 90% decentralised maxTxSize: 4096 minFeeA: 100 maxBlockBodySize: 239857 diff --git a/nix/.stack.nix/cardano-wallet-core-integration.nix b/nix/.stack.nix/cardano-wallet-core-integration.nix index 3aea3eb8855..468349bfb9a 100644 --- a/nix/.stack.nix/cardano-wallet-core-integration.nix +++ b/nix/.stack.nix/cardano-wallet-core-integration.nix @@ -55,7 +55,6 @@ (hsPkgs."http-types" or (errorHandler.buildDepError "http-types")) (hsPkgs."memory" or (errorHandler.buildDepError "memory")) (hsPkgs."process" or (errorHandler.buildDepError "process")) - (hsPkgs."QuickCheck" or (errorHandler.buildDepError "QuickCheck")) (hsPkgs."retry" or (errorHandler.buildDepError "retry")) (hsPkgs."scrypt" or (errorHandler.buildDepError "scrypt")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) diff --git a/nix/.stack.nix/cardano-wallet-shelley.nix b/nix/.stack.nix/cardano-wallet-shelley.nix index 858d69a7cc2..4d7fcdfab09 100644 --- a/nix/.stack.nix/cardano-wallet-shelley.nix +++ b/nix/.stack.nix/cardano-wallet-shelley.nix @@ -68,7 +68,6 @@ (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 ee2a6595aa735a893fa9e395c0ab7c274b252b65 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Mon, 22 Jun 2020 13:41:38 +0200 Subject: [PATCH 5/9] Add MsgWillOpenDB log message --- lib/core/src/Cardano/DB/Sqlite.hs | 3 +++ lib/core/src/Cardano/Pool/DB/Sqlite.hs | 3 ++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/core/src/Cardano/DB/Sqlite.hs b/lib/core/src/Cardano/DB/Sqlite.hs index b9e18055e0e..09778b9c311 100644 --- a/lib/core/src/Cardano/DB/Sqlite.hs +++ b/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 -> diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 2b6871c8bd7..175ed534fe2 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -129,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 From 736d5236e4d24ecbf065770d6f6f53e51ff47d13 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Mon, 22 Jun 2020 13:41:44 +0200 Subject: [PATCH 6/9] Log static metadata server urls when launched --- lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs | 6 ++++++ lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs | 4 ++-- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs index dfcc133fc4a..1fd8c345c32 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Launch.hs @@ -495,6 +495,7 @@ withStakePool tr baseDir idx params action = bracketTracer' tr "withStakePool" $ do createDirectory dir withStaticServer dir $ \url -> do + traceWith tr $ MsgStartedStaticServer dir url (cfg, opPub, tx) <- setupStakePoolData tr dir name params url withCardanoNodeProcess tr name cfg $ \_ -> do submitTx tr name tx @@ -1096,6 +1097,7 @@ withSystemTempDir tr name action = do data ClusterLog = MsgCartouche | MsgLauncher String LauncherLog + | MsgStartedStaticServer String FilePath | MsgTempNoCleanup FilePath | MsgBracket BracketLog | MsgCLIStatus String ExitCode String String @@ -1113,6 +1115,9 @@ instance ToText ClusterLog where MsgCartouche -> cartouche MsgLauncher name msg -> T.pack name <> " " <> toText msg + MsgStartedStaticServer baseUrl fp -> + "Started a static server for " <> T.pack fp + <> " at " <> T.pack baseUrl MsgTempNoCleanup dir -> "NO_CLEANUP of temporary directory " <> T.pack dir MsgBracket b -> toText b @@ -1145,6 +1150,7 @@ instance HasSeverityAnnotation ClusterLog where getSeverityAnnotation = \case MsgCartouche -> Warning MsgLauncher _ msg -> getSeverityAnnotation msg + MsgStartedStaticServer _ _ -> Info MsgTempNoCleanup _ -> Notice MsgBracket _ -> Debug MsgCLIStatus _ ExitSuccess _ _-> Debug diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index aab4a9121ef..ae5d583b5b7 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -82,6 +82,8 @@ import Control.Tracer ( Tracer, contramap, traceWith ) import Data.Generics.Internal.VL.Lens ( view ) +import Data.List + ( sortOn ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Map @@ -94,8 +96,6 @@ import Data.Ord ( Down (..) ) import Data.Quantity ( Percentage (..), Quantity (..) ) -import Data.Sort - ( sortOn ) import Data.Text.Class ( ToText (..) ) import Data.Word From 12f7fc17e51b7d90ecf269b2040a4250a63b56f8 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 23 Jun 2020 19:30:27 +0200 Subject: [PATCH 7/9] use type applications instead of 'fixTypeInference' function --- .../Test/Integration/Scenario/API/Shelley/StakePools.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 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 684ffa6c159..017591290c5 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 @@ -426,7 +426,6 @@ spec = do , expectErrorMessage $ errMsg403DelegationFee fee ] - let fixTypeInference = True `shouldBe` True 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 @@ -520,15 +519,13 @@ spec = do ] it "STAKE_POOLS_LIST_05 - Fails without query parameter" $ \ctx -> do - fixTypeInference - 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 - fixTypeInference 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 From e543f195c439a88a04f4522df5e646bb7f7ee21c Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 23 Jun 2020 19:33:13 +0200 Subject: [PATCH 8/9] revert changing decentralizationParam to 0.1 We need to keep this one quite high at the moment in order to prevent the cluster from rolling back too often. The wallet can handle rollback quite nicely, but the integration scenarios cannot (most of them). A lot of scenarios are built following a basic fixture -> action -> assertions principle, and rolling back the fixture can have very negative effects on the rest. We could run every scenario multiple times (at least twice) to maybe cope with intermediate failures due to rollback... --- lib/shelley/test/data/cardano-node-shelley/genesis.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/shelley/test/data/cardano-node-shelley/genesis.yaml b/lib/shelley/test/data/cardano-node-shelley/genesis.yaml index b5fb1745391..5e2452b0e24 100644 --- a/lib/shelley/test/data/cardano-node-shelley/genesis.yaml +++ b/lib/shelley/test/data/cardano-node-shelley/genesis.yaml @@ -6,7 +6,7 @@ protocolParams: protocolVersion: minor: 0 major: 0 - decentralisationParam: 0.1 # means 90% decentralised + decentralisationParam: 0.97 # means 3% decentralised maxTxSize: 4096 minFeeA: 100 maxBlockBodySize: 239857 From d88fcf09500b80057be3e9cf734851f65f301bae Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 23 Jun 2020 20:00:15 +0200 Subject: [PATCH 9/9] split assertions on block production and saturation out in a separate scenario So that we don't mix concerns between scenarios and we can lower down a bit the assertions without loosing much of the testing benefits. --- .../Scenario/API/Shelley/StakePools.hs | 26 +++++++++---------- 1 file changed, 12 insertions(+), 14 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 017591290c5..1872373e5e9 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 @@ -46,7 +46,7 @@ import Data.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 (..) @@ -445,12 +445,6 @@ spec = do , expectListField 2 (#metrics . #relativeStake) (.> Quantity (unsafeMkPercentage 0)) - , expectListField 0 - (#metrics . #saturation) (.> 0) - , expectListField 1 - (#metrics . #saturation) (.> 0) - , expectListField 2 - (#metrics . #saturation) (.> 0) ] it "eventually has correct margin and cost" $ \ctx -> do @@ -474,17 +468,21 @@ spec = do , expectListField 2 #margin (`shouldBe` Just (Quantity $ unsafeMkPercentage 0.1 )) - - , expectListField 0 - (#metrics . #producedBlocks) (.> Quantity 0) - , expectListField 1 - (#metrics . #producedBlocks) (.> Quantity 0) - , expectListField 2 - (#metrics . #producedBlocks) (.> Quantity 0) -- TODO: Test that we have non-zero non-myopic member -- rewards, and sort by it. ] + 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