From 657e541319545f47d35bd5d742209007adc4eb5b Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 28 Jul 2020 01:20:14 +0200 Subject: [PATCH] remove duplicated logic between 'readNextWithdrawal' and 'queryRewardBalance' This partially revert some of the previous commit, but that's for the best. --- lib/core/src/Cardano/Wallet.hs | 111 ++++++++++------------ lib/core/src/Cardano/Wallet/Api/Server.hs | 14 +-- lib/core/src/Cardano/Wallet/Network.hs | 27 +----- 3 files changed, 58 insertions(+), 94 deletions(-) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index cab444d304f..62db73da0b9 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -78,6 +78,9 @@ module Cardano.Wallet , rollbackBlocks , checkWalletIntegrity , readNextWithdrawal + , readChimericAccount + , someChimericAccount + , queryRewardBalance , ErrWalletAlreadyExists (..) , ErrNoSuchWallet (..) , ErrListUTxOStatistics (..) @@ -196,7 +199,6 @@ import Cardano.Wallet.Network , FollowLog (..) , NetworkLayer (..) , follow - , getAccountBalanceRetry ) import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..) @@ -206,6 +208,7 @@ import Cardano.Wallet.Primitive.AddressDerivation , HardDerivation (..) , Index (..) , MkKeyFingerprint (..) + , NetworkDiscriminant , Passphrase , PaymentAddress (..) , WalletKey (..) @@ -354,7 +357,7 @@ import Data.Foldable import Data.Function ( (&) ) import Data.Functor - ( ($>) ) + ( ($>), (<&>) ) import Data.Generics.Internal.VL.Lens ( Lens', view, (^.) ) import Data.Generics.Labels @@ -907,96 +910,77 @@ 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 - -> 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 + -> Quantity "lovelace" Word64 + -> IO (Quantity "lovelace" Word64) +readNextWithdrawal ctx wid (Quantity withdrawal) = db & \DBLayer{..} -> do + liftIO (atomically $ readProtocolParameters $ PrimaryKey wid) <&> \case -- May happen if done very early, in which case, rewards are probably -- not woth considering anyway. - Nothing -> pure (Quantity 0) - - Just ProtocolParameters{txParameters} -> do + Nothing -> Quantity 0 + Just ProtocolParameters{txParameters} -> let policy = W.getFeePolicy txParameters - let costOfWithdrawal = + costOfWithdrawal = minFee policy (mempty { withdrawal }) - minFee policy mempty - pure $ if toInteger withdrawal < 2 * costOfWithdrawal + in + if toInteger withdrawal < 2 * costOfWithdrawal then Quantity 0 else Quantity withdrawal where db = ctx ^. dbLayer @s @k tl = ctx ^. transactionLayer @t @k - 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 +readChimericAccount + :: forall ctx s k. + ( HasDBLayer s k ctx + , HasRewardAccount s k + ) + => ctx + -> WalletId + -> ExceptT ErrNoSuchWallet IO ChimericAccount +readChimericAccount ctx wid = db & \DBLayer{..} -> do + cp <- mapExceptT atomically . withNoSuchWallet wid $ + readCheckpoint (PrimaryKey wid) + pure $ toChimericAccount @s @k . rewardAccountKey $ getState cp + where + db = ctx ^. dbLayer @s @k - 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) +someChimericAccount + :: forall s k (n :: NetworkDiscriminant). + ( s ~ SeqState n k + , k ~ ShelleyKey + ) + => SomeMnemonic + -> ChimericAccount +someChimericAccount mw = + toChimericAccount @s (publicKey acctK) + where + rootK = Shelley.generateKeyFromSeed (mw, Nothing) mempty + acctK = deriveRewardAccount mempty rootK -- | 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. queryRewardBalance - :: forall ctx s t k. - ( HasDBLayer s k ctx - , HasNetworkLayer t ctx - , HasRewardAccount s k + :: forall ctx t. + ( HasNetworkLayer t ctx ) => ctx - -> WalletId + -> ChimericAccount -> ExceptT ErrFetchRewards IO (Quantity "lovelace" Word64) -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 +queryRewardBalance ctx acct = do + mapExceptT (fmap handleErr) $ getAccountBalance nw acct where - pk = PrimaryKey wid - db = ctx ^. dbLayer @s @k nw = ctx ^. networkLayer @t handleErr = \case Right x -> Right x @@ -1019,7 +1003,10 @@ manageRewardBalance manageRewardBalance ctx wid = db & \DBLayer{..} -> do watchNodeTip $ \bh -> do traceWith tr $ MsgRewardBalanceQuery bh - query <- runExceptT $ queryRewardBalance @ctx @s @t @k ctx wid + query <- runExceptT $ do + acct <- withExceptT ErrFetchRewardsNoSuchWallet $ + readChimericAccount @ctx @s @k ctx wid + queryRewardBalance @ctx @t ctx acct traceWith tr $ MsgRewardBalanceResult query case query of Right amt -> do diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 644e61d806c..8f4e88ade7f 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -234,8 +234,6 @@ 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) @@ -1203,7 +1201,6 @@ postTransaction , HardDerivation k , Bounded (Index (AddressIndexDerivationType k) 'AddressK) , HasRewardAccount s k - , HasRewardAccount s ShelleyKey ) => ctx -> ArgGenChange s @@ -1217,7 +1214,10 @@ postTransaction ctx genChange (ApiT wid) withdrawRewards body = do selection <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do withdrawal <- if withdrawRewards - then liftHandler $ W.readNextWithdrawal @_ @s @t @k wrk wid (Left wid) + then do + acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid + raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct + liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw else pure (Quantity 0) liftHandler $ W.selectCoinsForPayment @_ @s @t wrk wid outs withdrawal @@ -1317,7 +1317,6 @@ postTransactionFee :: forall ctx s t k n. ( Buildable (ErrValidateSelection t) , HasRewardAccount s k - , HasRewardAccount s ShelleyKey , ctx ~ ApiLayer s t k ) => ctx @@ -1329,7 +1328,10 @@ postTransactionFee ctx (ApiT wid) withdrawRewards body = do let outs = coerceCoin <$> (body ^. #payments) withWorkerCtx ctx wid liftE liftE $ \wrk -> do withdrawal <- if withdrawRewards - then liftHandler $ W.readNextWithdrawal @_ @s @t @k wrk wid (Left wid) + then do + acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid + raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct + liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw else pure $ Quantity 0 fee <- liftHandler $ W.estimateFeeForPayment @_ @s @t @k wrk wid outs withdrawal pure $ apiFee fee diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index ce9d26e319a..96e19f532b1 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -20,7 +20,6 @@ module Cardano.Wallet.Network , FollowAction (..) , FollowExit (..) , GetStakeDistribution - , getAccountBalanceRetry -- * Errors , ErrNetworkUnavailable (..) @@ -70,12 +69,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT (..), runExceptT ) import Control.Retry - ( RetryPolicyM - , constantDelay - , limitRetries - , limitRetriesByCumulativeDelay - , retrying - ) + ( RetryPolicyM, constantDelay, limitRetriesByCumulativeDelay, retrying ) import Control.Tracer ( Tracer, traceWith ) import Data.Functor @@ -165,25 +159,6 @@ 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 -------------------------------------------------------------------------------}