Merge #1768

1768: Store delegation reward account balances in the database r=KtorZ a=rvl ### Issue Number ADP-302 / #1750 ### Overview Turns out querying reward account balances can be slow. This is not good if it's done when listing/getting wallets. Better to do these queries in a separate thread and cache the results in the database. - [x] Add new database table for the latest known wallet reward account balance. - [x] Use the database when getting the reward account balance. - [x] Add a network layer method to watch the node tip. - [x] Update the account balance in each wallet when the node tip changes (asynchronously). - [x] Store reward account balance in db as it arrives. - [x] Adapt Jörmungandr network layer ### Comments - [ ] STAKE_POOLS_JOIN_04 test passes Co-authored-by: Rodney Lorrimar <[email protected]> Co-authored-by: KtorZ <[email protected]>
cardano-foundation · Jun 27, 2020 · 66a8604 · 66a8604
2 parents d1d635f + 5102817
commit 66a8604
Show file tree

Hide file tree

Showing 31 changed files with 369 additions and 124 deletions.
diff --git a/.buildkite/push-branch.sh b/.buildkite/push-branch.sh
@@ -54,7 +54,7 @@ fi
 
 advance_branch "$this_branch" "$head"
 
-common_ref=$(git merge-base "$this_branch" "$other_branch" || true)
+common_ref=$(git merge-base "origin/$this_branch" "origin/$other_branch" || true)
 
 if [ -n "$common_ref" ]; then
   advance_branch "$common_branch" "$common_ref"

diff --git a/.gitattributes b/.gitattributes
@@ -3,3 +3,4 @@
 # That is stuff that is generated by nix-tools stack-to-nix
 
 nix/.stack.nix/*.nix linguist-generated=true merge=union
+nix/sources.nix linguist-generated=true
diff --git a/lib/byron/src/Cardano/Wallet/Byron.hs b/lib/byron/src/Cardano/Wallet/Byron.hs
@@ -274,6 +274,7 @@ serveWallet
             (DefaultFieldValues $ getActiveSlotCoefficient gp)
             databaseDir
         Server.newApiLayer walletEngineTracer params nl' tl db
+            (\_ _ -> pure ())
       where
         gp@GenesisParameters
             { getGenesisBlockHash

diff --git a/lib/byron/src/Cardano/Wallet/Byron/Network.hs b/lib/byron/src/Cardano/Wallet/Byron/Network.hs
@@ -241,6 +241,7 @@ withNetworkLayer tr np addrInfo versionData action = do
             , postTx = _postTx localTxSubmissionQ
             , stakeDistribution = _stakeDistribution
             , getAccountBalance = _getAccountBalance
+            , watchNodeTip = _watchNodeTip
             }
   where
     gp@W.GenesisParameters
@@ -295,9 +296,15 @@ withNetworkLayer tr np addrInfo versionData action = do
         case result of
             SubmitSuccess -> pure ()
             SubmitFail err -> throwE $ ErrPostTxBadRequest $ T.pack (show err)
+
     _stakeDistribution =
         notImplemented "stakeDistribution"
 
+    -- At the moment it's not necessasy to implement this method unless
+    -- monitoring a reward account.
+    _watchNodeTip =
+        notImplemented "stakeDistribution"
+
 -- | Type representing a network client running two mini-protocols to sync
 -- from the chain and, submit transactions.
 type NetworkClient m = OuroborosApplication

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
@@ -47,7 +47,7 @@ import Data.Quantity
 import Data.Text.Class
     ( toText )
 import Test.Hspec
-    ( SpecWith, describe, it, shouldBe, shouldSatisfy, xit )
+    ( SpecWith, describe, it, shouldBe, shouldSatisfy, pendingWith )
 import Test.Integration.Framework.DSL
     ( Context (..)
     , Headers (..)
@@ -265,7 +265,11 @@ spec = do
                 [ expectField #delegation (`shouldBe` notDelegating [])
                 ]
 
-    xit "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \ctx -> do
+    it "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \ctx -> do
+        pendingWith
+            "Somehow, we can't get the cluster to produce rewards. Everyone \
+            \is clueless, including the node's guys. The reward balance seems \
+            \to work fine on the Shelley testnet though.."
         w <- fixtureWallet ctx
         pool:_ <- map (view #id) . snd
             <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
@@ -74,6 +74,7 @@ module Cardano.Wallet
     , updateWalletPassphrase
     , walletSyncProgress
     , fetchRewardBalance
+    , manageRewardBalance
     , rollbackBlocks
     , checkWalletIntegrity
     , ErrWalletAlreadyExists (..)
@@ -209,8 +210,6 @@ import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( ByronKey )
 import Cardano.Wallet.Primitive.AddressDerivation.Icarus
     ( IcarusKey )
-import Cardano.Wallet.Primitive.AddressDerivation.Shelley
-    ( ShelleyKey )
 import Cardano.Wallet.Primitive.AddressDiscovery
     ( CompareDiscovery (..)
     , GenChange (..)
@@ -355,7 +354,7 @@ import Data.Generics.Product.Typed
 import Data.List.NonEmpty
     ( NonEmpty )
 import Data.Maybe
-    ( isJust, mapMaybe )
+    ( mapMaybe )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Set
@@ -364,8 +363,6 @@ import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock
     ( UTCTime, getCurrentTime )
-import Data.Type.Equality
-    ( testEquality )
 import Data.Vector.Shuffle
     ( shuffle )
 import Data.Word
@@ -380,8 +377,6 @@ import Safe
     ( lastMay )
 import Statistics.Quantile
     ( medianUnbiased, quantiles )
-import Type.Reflection
-    ( Typeable, typeRep )
 
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
@@ -866,51 +861,90 @@ deleteWallet ctx wid = db & \DBLayer{..} -> do
   where
     db = ctx ^. dbLayer @s @k
 
--- | Fetch the reward balance of a given wallet.
+-- | Fetch the cached reward balance of a given wallet from the database.
+fetchRewardBalance
+    :: forall ctx s k.
+        ( HasDBLayer s k ctx
+        )
+    => ctx
+    -> WalletId
+    -> IO (Quantity "lovelace" Word64)
+fetchRewardBalance ctx wid = db & \DBLayer{..} ->
+    atomically $ readDelegationRewardBalance pk
+  where
+    pk = PrimaryKey wid
+    db = ctx ^. dbLayer @s @k
+
+-- | Query the node for the reward balance of a given wallet.
 --
 -- Rather than force all callers of 'readWallet' to wait for fetching the
 -- account balance (via the 'NetworkLayer'), we expose this function for it.
-fetchRewardBalance
+queryRewardBalance
     :: forall ctx s t k.
         ( HasDBLayer s k ctx
         , HasNetworkLayer t ctx
         , HasRewardAccount s k
-        , HasLogger WalletLog ctx
-        , Typeable k
         )
     => ctx
     -> WalletId
     -> ExceptT ErrFetchRewards IO (Quantity "lovelace" Word64)
-fetchRewardBalance ctx wid = db & \DBLayer{..} -> do
-    -- FIXME: issue #1750 re-enable querying reward balance when it's faster
-    if isShelleyKey then do
-        lift $ traceWith tr MsgTemporaryDisableFetchReward
-        pure $ Quantity 0
-    else do
-        let pk = PrimaryKey wid
-        cp <- withExceptT ErrFetchRewardsNoSuchWallet
-            . mapExceptT atomically
-            . withNoSuchWallet wid
-            $ readCheckpoint pk
-        mapExceptT (fmap handleErr)
-            . getAccountBalance nw
-            . toChimericAccount @s @k
-            . rewardAccountKey
-            $ getState cp
+queryRewardBalance ctx wid = db & \DBLayer{..} -> do
+    cp <- withExceptT ErrFetchRewardsNoSuchWallet
+        . mapExceptT atomically
+        . withNoSuchWallet wid
+        $ readCheckpoint pk
+    mapExceptT (fmap handleErr)
+        . getAccountBalance nw
+        . toChimericAccount @s @k
+        . rewardAccountKey
+        $ getState cp
   where
+    pk = PrimaryKey wid
     db = ctx ^. dbLayer @s @k
     nw = ctx ^. networkLayer @t
-    tr = ctx ^. logger
     handleErr = \case
         Right x -> Right x
         Left (ErrGetAccountBalanceAccountNotFound _) ->
             Right $ Quantity 0
         Left (ErrGetAccountBalanceNetworkUnreachable e) ->
             Left $ ErrFetchRewardsNetworkUnreachable e
 
-    isShelleyKey = isJust $ testEquality
-        (typeRep @(k 'RootK XPrv))
-        (typeRep @(ShelleyKey 'RootK XPrv))
+manageRewardBalance
+    :: forall ctx s t k.
+        ( HasLogger WalletLog ctx
+        , HasNetworkLayer t ctx
+        , HasDBLayer s k ctx
+        , HasRewardAccount s k
+        , ctx ~ WalletLayer s t k
+        )
+    => ctx
+    -> WalletId
+    -> IO ()
+manageRewardBalance ctx wid = db & \DBLayer{..} -> do
+    watchNodeTip $ \bh -> do
+         traceWith tr $ MsgRewardBalanceQuery bh
+         query <- runExceptT $ queryRewardBalance @ctx @s @t @k ctx wid
+         traceWith tr $ MsgRewardBalanceResult query
+         case query of
+            Right amt -> do
+                res <- atomically $ runExceptT $ putDelegationRewardBalance pk amt
+                -- It can happen that the wallet doesn't exist _yet_, whereas we
+                -- already have a reward balance. If that's the case, we log and
+                -- move on.
+                case res of
+                    Left err -> traceWith tr $ MsgRewardBalanceNoSuchWallet err
+                    Right () -> pure ()
+            Left _err ->
+                -- Occasionaly failing to query is generally not fatal. It will
+                -- just update the balance next time the tip changes.
+                pure ()
+    traceWith tr MsgRewardBalanceExited
+
+  where
+    pk = PrimaryKey wid
+    db = ctx ^. dbLayer @s @k
+    NetworkLayer{watchNodeTip} = ctx ^. networkLayer @t
+    tr = ctx ^. logger @WalletLog
 
 {-------------------------------------------------------------------------------
                                     Address
@@ -1957,6 +1991,7 @@ data ErrQuitStakePool
 data ErrFetchRewards
     = ErrFetchRewardsNetworkUnreachable ErrNetworkUnavailable
     | ErrFetchRewardsNoSuchWallet ErrNoSuchWallet
+    deriving (Generic, Eq, Show)
 
 data ErrSelectForMigration
     = ErrSelectForMigrationNoSuchWallet ErrNoSuchWallet
@@ -2058,7 +2093,10 @@ data WalletLog
     | MsgDelegationCoinSelection CoinSelection
     | MsgPaymentCoinSelection CoinSelection
     | MsgPaymentCoinSelectionAdjusted CoinSelection
-    | MsgTemporaryDisableFetchReward
+    | MsgRewardBalanceQuery BlockHeader
+    | MsgRewardBalanceResult (Either ErrFetchRewards (Quantity "lovelace" Word64))
+    | MsgRewardBalanceNoSuchWallet ErrNoSuchWallet
+    | MsgRewardBalanceExited
     deriving (Show, Eq)
 
 instance ToText WalletLog where
@@ -2100,8 +2138,18 @@ instance ToText WalletLog where
             "Coins selected for payment: \n" <> pretty sel
         MsgPaymentCoinSelectionAdjusted sel ->
             "Coins after fee adjustment: \n" <> pretty sel
-        MsgTemporaryDisableFetchReward ->
-            "FIXME: (issue #1750) fetching reward temporarily disabled."
+        MsgRewardBalanceQuery bh ->
+            "Updating the reward balance for block " <> pretty bh
+        MsgRewardBalanceResult (Right amt) ->
+            "The reward balance is " <> pretty amt
+        MsgRewardBalanceNoSuchWallet err ->
+            "Trying to store a balance for a wallet that doesn't exist (yet?): " <>
+            T.pack (show err)
+        MsgRewardBalanceResult (Left err) ->
+            "Problem fetching reward balance. Will try again on next chain update. " <>
+            T.pack (show err)
+        MsgRewardBalanceExited ->
+            "Reward balance worker has exited."
 
 instance HasPrivacyAnnotation WalletLog
 instance HasSeverityAnnotation WalletLog where
@@ -2120,4 +2168,8 @@ instance HasSeverityAnnotation WalletLog where
         MsgDelegationCoinSelection _ -> Debug
         MsgPaymentCoinSelection _ -> Debug
         MsgPaymentCoinSelectionAdjusted _ -> Debug
-        MsgTemporaryDisableFetchReward -> Warning
+        MsgRewardBalanceQuery _ -> Debug
+        MsgRewardBalanceResult (Right _) -> Debug
+        MsgRewardBalanceResult (Left _) -> Notice
+        MsgRewardBalanceNoSuchWallet{} -> Warning
+        MsgRewardBalanceExited -> Notice
Original file line number	Diff line number	Diff line change
Expand Up		@@ -3,3 +3,4 @@
		# That is stuff that is generated by nix-tools stack-to-nix

		nix/.stack.nix/*.nix linguist-generated=true merge=union
		nix/sources.nix linguist-generated=true