make it possible to query rewards of any arbitrary reward account

  Yet, the server still query rewards from standard wallet reward
  account at the moment. Next commits will make it possible for users to
  pass a mnemonic to the API.

lib/core/src/Cardano/Wallet.hs

@@ -174,6 +174,8 @@ import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
+import Cardano.Mnemonic
+    ( SomeMnemonic )
 import Cardano.Slotting.Slot
     ( SlotNo (..) )
 import Cardano.Wallet.DB
@@ -194,6 +196,7 @@ import Cardano.Wallet.Network
     , FollowLog (..)
     , NetworkLayer (..)
     , follow
+    , getAccountBalanceRetry
     )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
@@ -216,6 +219,8 @@ import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( ByronKey, unsafeMkByronKeyFromMasterKey )
 import Cardano.Wallet.Primitive.AddressDerivation.Icarus
     ( IcarusKey )
+import Cardano.Wallet.Primitive.AddressDerivation.Shelley
+    ( ShelleyKey )
 import Cardano.Wallet.Primitive.AddressDiscovery
     ( CompareDiscovery (..)
     , GenChange (..)
@@ -387,6 +392,7 @@ import Safe
 import Statistics.Quantile
     ( medianUnbiased, quantiles )
 
+import qualified Cardano.Wallet.Primitive.AddressDerivation.Shelley as Shelley
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
 import qualified Cardano.Wallet.Primitive.CoinSelection.Random as CoinSelection
@@ -901,14 +907,19 @@ readNextWithdrawal
     :: forall ctx s t k.
         ( HasDBLayer s k ctx
         , HasTransactionLayer t k ctx
+        , HasNetworkLayer t ctx
+        , HasRewardAccount s k
+        , HasRewardAccount s ShelleyKey
         )
     => ctx
     -> WalletId
-    -> IO (Quantity "lovelace" Word64)
-readNextWithdrawal ctx wid = db & \DBLayer{..} -> do
-    (pp, withdrawal) <- atomically $ (,)
-        <$> readProtocolParameters pk
-        <*> fmap getQuantity (readDelegationRewardBalance pk)
+    -> Either WalletId SomeMnemonic
+    -> ExceptT ErrFetchRewards IO (Quantity "lovelace" Word64)
+readNextWithdrawal ctx wid src = db & \DBLayer{..} -> do
+    account <- either fromOwnWallet (pure . fromExternalWallet) src
+    (pp, Quantity withdrawal) <- (,)
+        <$> liftIO (atomically $ readProtocolParameters $ PrimaryKey wid)
+        <*> mapExceptT (fmap handleErr) (getAccountBalanceRetry nl account)
     case pp of
         -- May happen if done very early, in which case, rewards are probably
         -- not woth considering anyway.
@@ -928,11 +939,38 @@ readNextWithdrawal ctx wid = db & \DBLayer{..} -> do
   where
     db = ctx ^. dbLayer @s @k
     tl = ctx ^. transactionLayer @t @k
-    pk = PrimaryKey wid
+    nl = ctx ^. networkLayer @t
 
     minFee :: FeePolicy -> CoinSelection -> Integer
     minFee policy = fromIntegral . getFee . minimumFee tl policy Nothing
 
+    handleErr = \case
+        Right x -> Right x
+        Left ErrGetAccountBalanceAccountNotFound{} ->
+            Right $ Quantity 0
+        Left (ErrGetAccountBalanceNetworkUnreachable e) ->
+            Left $ ErrFetchRewardsNetworkUnreachable e
+
+    fromOwnWallet
+        :: WalletId
+        -> ExceptT ErrFetchRewards IO ChimericAccount
+    fromOwnWallet _wid = db & \DBLayer{..} -> do
+        cp <- withExceptT ErrFetchRewardsNoSuchWallet
+            . mapExceptT atomically
+            . withNoSuchWallet wid
+            $ readCheckpoint (PrimaryKey wid)
+        pure $ toChimericAccount @s @k . rewardAccountKey $ getState cp
+
+    fromExternalWallet
+        :: SomeMnemonic
+        -> ChimericAccount
+    fromExternalWallet mw =
+        let
+            rootK = Shelley.generateKeyFromSeed (mw, Nothing) mempty
+            acctK = deriveRewardAccount mempty rootK
+        in
+            toChimericAccount @s (publicKey acctK)
+
 -- | Query the node for the reward balance of a given wallet.
 --
 -- Rather than force all callers of 'readWallet' to wait for fetching the
@@ -1464,8 +1502,6 @@ signPayment
         , HasNetworkLayer t ctx
         , IsOwned s k
         , GenChange s
-        , HardDerivation k
-        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         )
     => ctx
     -> WalletId

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

@@ -234,6 +234,8 @@ import Cardano.Wallet.Primitive.AddressDerivation.Byron
     ( ByronKey, mkByronKeyFromMasterKey )
 import Cardano.Wallet.Primitive.AddressDerivation.Icarus
     ( IcarusKey )
+import Cardano.Wallet.Primitive.AddressDerivation.Shelley
+    ( ShelleyKey )
 import Cardano.Wallet.Primitive.AddressDiscovery
     ( CompareDiscovery
     , GenChange (ArgGenChange)
@@ -1200,6 +1202,8 @@ postTransaction
         , ctx ~ ApiLayer s t k
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        , HasRewardAccount s k
+        , HasRewardAccount s ShelleyKey
         )
     => ctx
     -> ArgGenChange s
@@ -1213,7 +1217,7 @@ postTransaction ctx genChange (ApiT wid) withdrawRewards body = do
 
     selection <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
         withdrawal <- if withdrawRewards
-            then liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid
+            then liftHandler $ W.readNextWithdrawal @_ @s @t @k wrk wid (Left wid)
             else pure (Quantity 0)
         liftHandler $ W.selectCoinsForPayment @_ @s @t wrk wid outs withdrawal
 
@@ -1312,6 +1316,8 @@ apiFee (FeeEstimation estMin estMax) = ApiFee (qty estMin) (qty estMax)
 postTransactionFee
     :: forall ctx s t k n.
         ( Buildable (ErrValidateSelection t)
+        , HasRewardAccount s k
+        , HasRewardAccount s ShelleyKey
         , ctx ~ ApiLayer s t k
         )
     => ctx
@@ -1323,7 +1329,7 @@ postTransactionFee ctx (ApiT wid) withdrawRewards body = do
     let outs = coerceCoin <$> (body ^. #payments)
     withWorkerCtx ctx wid liftE liftE $ \wrk -> do
         withdrawal <- if withdrawRewards
-            then liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid
+            then liftHandler $ W.readNextWithdrawal @_ @s @t @k wrk wid (Left wid)
             else pure $ Quantity 0
         fee <- liftHandler $ W.estimateFeeForPayment @_ @s @t @k wrk wid outs withdrawal
         pure $ apiFee fee

lib/core/src/Cardano/Wallet/Network.hs

@@ -20,6 +20,7 @@ module Cardano.Wallet.Network
     , FollowAction (..)
     , FollowExit (..)
     , GetStakeDistribution
+    , getAccountBalanceRetry
 
     -- * Errors
     , ErrNetworkUnavailable (..)
@@ -67,9 +68,14 @@ import Control.Exception
 import Control.Monad
     ( when )
 import Control.Monad.Trans.Except
-    ( ExceptT, runExceptT )
+    ( ExceptT (..), runExceptT )
 import Control.Retry
-    ( RetryPolicyM, constantDelay, limitRetriesByCumulativeDelay, retrying )
+    ( RetryPolicyM
+    , constantDelay
+    , limitRetries
+    , limitRetriesByCumulativeDelay
+    , retrying
+    )
 import Control.Tracer
     ( Tracer, traceWith )
 import Data.Functor
@@ -159,6 +165,25 @@ instance Functor m => Functor (NetworkLayer m target) where
         { nextBlocks = fmap (fmap f) . nextBlocks nl
         }
 
+-- Fetching the account balance may sometimes fail, especially on epoch
+-- boundaries. Therefore, we add some retrying mecanism here to cope with
+-- that nicely. 'readNextWithdrawal' is typically called by one-time
+-- handlers like 'postTransactions' and not by workers polling things
+-- regularly, so retrying a few times is okay here.
+getAccountBalanceRetry
+    :: NetworkLayer IO target block
+    -> ChimericAccount
+    -> ExceptT ErrGetAccountBalance IO (Quantity "lovelace" Word64)
+getAccountBalanceRetry nl account = ExceptT $
+    retrying policy decision (const $ runExceptT $ getAccountBalance nl account)
+  where
+    second = 1000*1000
+    policy = constantDelay second <> limitRetries 3
+    decision _ = \case
+        Right{} -> pure False
+        Left ErrGetAccountBalanceAccountNotFound{} -> pure False
+        Left ErrGetAccountBalanceNetworkUnreachable{} -> pure True
+
 {-------------------------------------------------------------------------------
                                   Errors
 -------------------------------------------------------------------------------}