Merge #2491

2491: Make estimateFee faster for large wallets r=rvl a=Anviking

# Issue Number

ADP-692

# Overview

- [ ] <s>Unify `selectAssets` and `selectAssetsNoOutputs`</s>
    - Idea was to allow `estimateFee` to call both `readUTxOIndex` and `selectAssets` — simplifying the call-sites — but I didn't end up doing this now. This seems right to me still, unless I have missed something?
- [x] Separate out a `readUTxOIndex` from `selectAssets`
- [x] Make sure `readUTxOIndex` is called only once, when repeating the coin selection 100x to estimate fees.


# Comments

- Viewing diff commit-per-commit may be helpful

Instead of 260s, we get 5s estimateFee time:
```
[bench-restore:Info:7] [2021-02-04 14:17:40.76 UTC] Restoring: [still restoring (4.01%)]
restoration: 736.4 s

Running read wallet
read wallet: 4.359 s

Running utxo statistics
utxo statistics: 28.54 ms

Running list addresses
list addresses: 1.010 s

Running list transactions
list transactions: 25.22 s

Running estimate tx fee
estimate tx fee: 5.091 s

[wallet:Error:60] [2021-02-04 14:18:18.44 UTC] Unexpected error following the chain: StatementAlreadyFinalized "BEGIN"
[wallet:Notice:60] [2021-02-04 14:18:18.44 UTC] Destroying cursor connection at ThreadId 61
restore: StatementAlreadyFinalized "BEGIN"


All results:
BenchSeqResults:
  benchName: 90.0-percent-seq
  restoreTime: 736.4 s
  readWalletTime: 4.359 s
  listAddressesTime: 1.010 s
  listTransactionsTime: 25.22 s
  estimateFeesTime: 5.091 s
  walletOverview:
     number of addresses: 54498
     number of transactions: 34810
     = Total value of 25008452939161007 lovelace across 28241 UTxOs
      ... 10                18
      ... 100               142
      ... 1000              133
      ... 10000             153
      ... 100000            280
      ... 1000000           1674
      ... 10000000          1302
      ... 100000000         1369
      ... 1000000000        1768
      ... 10000000000       3139
      ... 100000000000      4682
      ... 1000000000000     9737
      ... 10000000000000    3634
      ... 100000000000000   202
      ... 1000000000000000  6
      ... 10000000000000000 2
      ... 45000000000000000 0

1,186,372,795,296 bytes allocated in the heap
 187,306,453,352 bytes copied during GC
     739,022,840 bytes maximum residency (626 sample(s))
      37,791,752 bytes maximum slop
             704 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0     1082118 colls, 1082118 par   541.175s  136.483s     0.0001s    0.0040s
  Gen  1       626 colls,   625 par   58.612s  14.913s     0.0238s    0.0730s

  Parallel GC work balance: 10.33% (serial 0%, perfect 100%)

  TASKS: 17 (1 bound, 16 peak workers (16 total), using -N4)

  SPARKS: 0(0 converted, 0 overflowed, 0 dud, 0 GC'd, 0 fizzled)

  INIT    time    0.002s  (  0.004s elapsed)
  MUT     time  582.358s  (638.775s elapsed)
  GC      time  599.788s  (151.396s elapsed)
  RP      time    0.000s  (  0.000s elapsed)
  PROF    time    0.000s  (  0.000s elapsed)
  EXIT    time    0.000s  (  0.001s elapsed)
  Total   time  1182.148s  (790.176s elapsed)

  Alloc rate    2,037,187,147 bytes per MUT second

  Productivity  49.3% of total user, 80.8% of total elapsed

Benchmark restore: FINISH
Completed 2 action(s).


```

<!-- Additional comments or screenshots to attach if any -->

<!--
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Jira will detect and link to this PR once created, but you can also link this PR in the description of the corresponding ticket
 ✓ Acknowledge any changes required to the Wiki
 ✓ Finally, in the PR description delete any empty sections and all text commented in <!--, so that this text does not appear in merge commit messages.
-->


Co-authored-by: Johannes Lund <[email protected]>
Co-authored-by: Rodney Lorrimar <[email protected]>

lib/core/src/Cardano/Wallet.hs

@@ -102,6 +102,7 @@ module Cardano.Wallet
  -- ** Payment
  , getTxExpiry
  , selectAssets
+ , readWalletUTxOIndex
  , selectAssetsNoOutputs
  , assignChangeAddresses
  , selectionToUnsignedTx
@@ -1243,6 +1244,18 @@ selectionToUnsignedTx sel s =
  amount = view #coin bundle
  assets = view #tokens bundle
 
+-- | Read a wallet checkpoint and index its UTxO, for 'selectAssets' and
+-- 'selectAssetsNoOutputs'.
+readWalletUTxOIndex
+ :: forall ctx s k. HasDBLayer s k ctx
+ => ctx
+ -> WalletId
+ -> ExceptT ErrNoSuchWallet IO (UTxOIndex, Wallet s, Set Tx)
+readWalletUTxOIndex ctx wid = do
+ (cp, _, pending) <- readWallet @ctx @s @k ctx wid
+ let utxo = UTxOIndex.fromUTxO $ availableUTxO @s pending cp
+ return (utxo, cp, pending)
+
 selectAssetsNoOutputs
  :: forall ctx s k result.
  ( HasTransactionLayer k ctx
@@ -1252,10 +1265,11 @@ selectAssetsNoOutputs
  )
  => ctx
  -> WalletId
+ -> (UTxOIndex, Wallet s, Set Tx)
  -> TransactionCtx
  -> (s -> SelectionResult TokenBundle -> result)
  -> ExceptT ErrSelectAssets IO result
-selectAssetsNoOutputs ctx wid tx transform = do
+selectAssetsNoOutputs ctx wid wal tx transform = do
  -- NOTE:
  -- Could be made nicer by allowing 'performSelection' to run with no target
  -- outputs, but to satisfy a minimum Ada target.
@@ -1269,7 +1283,7 @@ selectAssetsNoOutputs ctx wid tx transform = do
  let dummyAddress = Address ""
  let dummyOutput = TxOut dummyAddress (TokenBundle.fromCoin deposit)
  let outs = dummyOutput :| []
- selectAssets @ctx @s @k ctx wid tx outs $ \s sel -> transform s $ sel
+ selectAssets @ctx @s @k ctx wal tx outs $ \s sel -> transform s $ sel
  { outputsCovered = mempty
  , changeGenerated =
  let
@@ -1302,34 +1316,26 @@ selectAssets
  :: forall ctx s k result.
  ( HasTransactionLayer k ctx
  , HasLogger WalletLog ctx
- , HasDBLayer s k ctx
  , HasNetworkLayer ctx
  )
  => ctx
- -> WalletId
+ -> (UTxOIndex, Wallet s, Set Tx)
  -> TransactionCtx
  -> NonEmpty TxOut
  -> (s -> SelectionResult TokenBundle -> result)
  -> ExceptT ErrSelectAssets IO result
-selectAssets ctx wid tx outs transform = do
- (cp, _, pending) <- withExceptT ErrSelectAssetsNoSuchWallet $
- readWallet @ctx @s @k ctx wid
- let s = getState cp
-
- guardWithdrawal pending
+selectAssets ctx (utxo, cp, pending) tx outs transform = do
+ guardPendingWithdrawal
 
  pp <- liftIO $ currentProtocolParameters nl
-
- let utxo :: UTxOIndex
- utxo = UTxOIndex.fromUTxO $ availableUTxO @s pending cp
-
  liftIO $ traceWith tr $ MsgSelectionStart utxo outs
  sel <- performSelection
  (calcMinimumCoinValue tl pp)
  (calcMinimumCost tl pp tx)
  (initSelectionCriteria tl pp tx utxo outs)
  liftIO $ traceWith tr $ MsgSelectionDone sel
- withExceptT ErrSelectAssetsSelectionError $ except (transform s <$> sel)
+ withExceptT ErrSelectAssetsSelectionError $ except $
+ transform (getState cp) <$> sel
  where
  nl = ctx ^. networkLayer
  tl = ctx ^. transactionLayer @k
@@ -1340,8 +1346,8 @@ selectAssets ctx wid tx outs transform = do
  -- withdrawal is executed, the reward pot is empty. So, to prevent two
  -- transactions with withdrawals to go through (which will inevitably cause
  -- one of them to never be inserted), we warn users early on about it.
- guardWithdrawal :: Set Tx -> ExceptT ErrSelectAssets IO ()
- guardWithdrawal pending = do
+ guardPendingWithdrawal :: ExceptT ErrSelectAssets IO ()
+ guardPendingWithdrawal =
  case Set.lookupMin $ Set.filter hasWithdrawal pending of
  Just pendingWithdrawal | withdrawalToCoin (txWithdrawal tx) /= Coin 0 ->
  throwE $ ErrSelectAssetsAlreadyWithdrawing pendingWithdrawal

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

@@ -1196,8 +1196,9 @@ selectCoins ctx genChange (ApiT wid) body = do
  let transform = \s sel ->
  W.assignChangeAddresses genChange sel s
  & uncurry W.selectionToUnsignedTx
+ w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  utx <- liftHandler
- $ W.selectAssets @_ @s @k wrk wid txCtx outs transform
+ $ W.selectAssets @_ @s @k wrk w txCtx outs transform
 
  pure $ mkApiCoinSelection [] Nothing utx
 
@@ -1239,8 +1240,9 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do
  let transform = \s sel ->
  W.assignChangeAddresses (delegationAddress @n) sel s
  & uncurry W.selectionToUnsignedTx
+ wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  utx <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx transform
+ $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx transform
  (_, path) <- liftHandler
  $ W.readRewardAccount @_ @s @k @n wrk wid
 
@@ -1263,8 +1265,7 @@ selectCoinsForQuit
  -> Handler (Api.ApiCoinSelection n)
 selectCoinsForQuit ctx (ApiT wid) = do
  withWorkerCtx ctx wid liftE liftE $ \wrk -> do
- action <- liftHandler
- $ W.quitStakePool @_ @s @k @n wrk wid
+ action <- liftHandler $ W.quitStakePool @_ @s @k @n wrk wid
 
  (wdrl, _mkRwdAcct) <- mkRewardAccountBuilder @_ @s @k @n ctx wid Nothing
  let txCtx = defaultTransactionCtx
@@ -1275,10 +1276,10 @@ selectCoinsForQuit ctx (ApiT wid) = do
  let transform = \s sel ->
  W.assignChangeAddresses (delegationAddress @n) sel s
  & uncurry W.selectionToUnsignedTx
+ wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  utx <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx transform
- (_, path) <- liftHandler
- $ W.readRewardAccount @_ @s @k @n wrk wid
+ $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx transform
+ (_, path) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid
 
  pure $ mkApiCoinSelection [] (Just (action, path)) utx
 
@@ -1435,8 +1436,9 @@ postTransaction ctx genChange (ApiT wid) body = do
  }
 
  (sel, tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+ w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  sel <- liftHandler
- $ W.selectAssets @_ @s @k wrk wid txCtx outs (const Prelude.id)
+ $ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id)
  (tx, txMeta, txTime, sealedTx) <- liftHandler
  $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
  liftHandler
@@ -1540,7 +1542,8 @@ postTransactionFee ctx (ApiT wid) body = do
  , txMetadata = getApiT <$> body ^. #metadata
  }
  withWorkerCtx ctx wid liftE liftE $ \wrk -> do
- let runSelection = W.selectAssets @_ @s @k wrk wid txCtx outs getFee
+ w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
+ let runSelection = W.selectAssets @_ @s @k wrk w txCtx outs getFee
  where outs = coerceCoin <$> body ^. #payments
  getFee = const (selectionDelta TokenBundle.getCoin)
  liftHandler $ mkApiFee Nothing <$> W.estimateFee runSelection
@@ -1589,9 +1592,10 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do
  , txTimeToLive = ttl
  , txDelegationAction = Just action
  }
-
+ wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  sel <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx (const Prelude.id)
+ $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
+ $ const Prelude.id
  (tx, txMeta, txTime, sealedTx) <- liftHandler
  $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
  liftHandler
@@ -1625,14 +1629,16 @@ delegationFee
  -> Handler ApiFee
 delegationFee ctx (ApiT wid) = do
  withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do
+ w <- withExceptT ErrSelectAssetsNoSuchWallet $
+ W.readWalletUTxOIndex @_ @s @k wrk wid
  deposit <- W.calcMinimumDeposit @_ @s @k wrk wid
- mkApiFee (Just deposit) <$> W.estimateFee (runSelection wrk deposit)
+ mkApiFee (Just deposit) <$> W.estimateFee (runSelection wrk deposit w)
  where
  txCtx :: TransactionCtx
  txCtx = defaultTransactionCtx
 
- runSelection wrk deposit =
- W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx calcFee
+ runSelection wrk deposit wal =
+ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx calcFee
  where
  calcFee _ = Coin.distance deposit . selectionDelta TokenBundle.getCoin
 
@@ -1669,8 +1675,10 @@ quitStakePool ctx (ApiT wid) body = do
  , txDelegationAction = Just action
  }
 
+ wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  sel <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx (const Prelude.id)
+ $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
+ $ const Prelude.id
  (tx, txMeta, txTime, sealedTx) <- liftHandler
  $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
  liftHandler

lib/shelley/bench/Restore.hs

@@ -454,7 +454,8 @@ benchmarksRnd _ w wid wname benchname restoreTime = do
  let out = TxOut (dummyAddress @n) (TokenBundle.fromCoin $ Coin 1)
  let txCtx = defaultTransactionCtx
  let getFee = const (selectionDelta TokenBundle.getCoin)
- let runSelection = W.selectAssets @_ @s @k w wid txCtx (out :| []) getFee
+ wal <- unsafeRunExceptT $ W.readWalletUTxOIndex @_ @s @k w wid
+ let runSelection = W.selectAssets @_ @s @k w wal txCtx (out :| []) getFee
  runExceptT $ withExceptT show $ W.estimateFee runSelection
 
  oneAddress <- genAddresses 1 cp
@@ -543,7 +544,8 @@ benchmarksSeq _ w wid _wname benchname restoreTime = do
  let out = TxOut (dummyAddress @n) (TokenBundle.fromCoin $ Coin 1)
  let txCtx = defaultTransactionCtx
  let getFee = const (selectionDelta TokenBundle.getCoin)
- let runSelection = W.selectAssets @_ @s @k w wid txCtx (out :| []) getFee
+ wal <- unsafeRunExceptT $ W.readWalletUTxOIndex w wid
+ let runSelection = W.selectAssets @_ @s @k w wal txCtx (out :| []) getFee
  runExceptT $ withExceptT show $ W.estimateFee runSelection
 
  let walletOverview = WalletOverview{utxo,addresses,transactions}