Factor out readUTxOIndex from estimateFee loop

readUTxOIndex is slow very slow. We should not run it 100x in a row
then.

This improves the estimateFee time of 30k UTxO wallets from 260s to 5s.

lib/core/src/Cardano/Wallet.hs

@@ -102,6 +102,7 @@ module Cardano.Wallet
  -- ** Payment
  , getTxExpiry
  , selectAssets
+ , readUTxOIndex
  , selectAssetsNoOutputs
  , assignChangeAddresses
  , selectionToUnsignedTx
@@ -1243,6 +1244,18 @@ selectionToUnsignedTx sel s =
  amount = view #coin bundle
  assets = view #tokens bundle
 
+-- | Helper funcion for selectAssets.
+readUTxOIndex
+ :: forall ctx s k. HasDBLayer s k ctx
+ => ctx
+ -> WalletId
+ -> ExceptT ErrNoSuchWallet IO (WalletId, UTxOIndex, Wallet s, Set Tx)
+readUTxOIndex ctx wid = do
+ (cp, _, pending) <- readWallet @ctx @s @k ctx wid
+ let utxo :: UTxOIndex
+ utxo = UTxOIndex.fromUTxO $ availableUTxO @s pending cp
+ return (wid, utxo, cp, pending)
+
 selectAssetsNoOutputs
  :: forall ctx s k result.
  ( HasTransactionLayer k ctx
@@ -1251,11 +1264,11 @@ selectAssetsNoOutputs
  , HasNetworkLayer ctx
  )
  => ctx
- -> WalletId
+ -> (WalletId, UTxOIndex, Wallet s, Set Tx)
  -> TransactionCtx
  -> (s -> SelectionResult TokenBundle -> result)
  -> ExceptT ErrSelectAssets IO result
-selectAssetsNoOutputs ctx wid tx transform = do
+selectAssetsNoOutputs ctx w@(wid, _, _, _) 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 +1282,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 w tx outs $ \s sel -> transform s $ sel
  { outputsCovered = mempty
  , changeGenerated =
  let
@@ -1302,27 +1315,20 @@ selectAssets
  :: forall ctx s k result.
  ( HasTransactionLayer k ctx
  , HasLogger WalletLog ctx
- , HasDBLayer s k ctx
  , HasNetworkLayer ctx
  )
  => ctx
- -> WalletId
+ -> (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
+selectAssets ctx (_wid, utxo, cp, pending) tx outs transform = do
  let s = getState cp
 
  guardWithdrawal pending
 
  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)
@@ -1341,8 +1347,8 @@ selectAssets ctx wid tx outs transform = do
  -- 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
- case Set.lookupMin $ Set.filter hasWithdrawal pending of
+ guardWithdrawal pending' = do
+ case Set.lookupMin $ Set.filter hasWithdrawal pending' of
  Just pendingWithdrawal | withdrawalToCoin (txWithdrawal tx) /= Coin 0 ->
  throwE $ ErrSelectAssetsAlreadyWithdrawing pendingWithdrawal
  _otherwise ->

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.readUTxOIndex @_ @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
+ w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid
  utx <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx transform
+ $ W.selectAssetsNoOutputs @_ @s @k wrk w txCtx transform
  (_, path) <- liftHandler
  $ W.readRewardAccount @_ @s @k @n wrk wid
 
@@ -1275,8 +1277,9 @@ selectCoinsForQuit ctx (ApiT wid) = do
  let transform = \s sel ->
  W.assignChangeAddresses (delegationAddress @n) sel s
  & uncurry W.selectionToUnsignedTx
+ w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid
  utx <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx transform
+ $ W.selectAssetsNoOutputs @_ @s @k wrk w txCtx transform
  (_, path) <- liftHandler
  $ W.readRewardAccount @_ @s @k @n wrk wid
 
@@ -1435,8 +1438,9 @@ postTransaction ctx genChange (ApiT wid) body = do
  }
 
  (sel, tx, txMeta, txTime) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+ w <- liftHandler $ W.readUTxOIndex @_ @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 +1544,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.readUTxOIndex @_ @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 +1594,9 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do
  , txTimeToLive = ttl
  , txDelegationAction = Just action
  }
-
+ w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid
  sel <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx (const Prelude.id)
+ $ W.selectAssetsNoOutputs @_ @s @k wrk w txCtx (const Prelude.id)
  (tx, txMeta, txTime, sealedTx) <- liftHandler
  $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
  liftHandler
@@ -1625,14 +1630,16 @@ delegationFee
  -> Handler ApiFee
 delegationFee ctx (ApiT wid) = do
  withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do
+ w <- withExceptT ErrSelectAssetsNoSuchWallet $
+ W.readUTxOIndex @_ @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 w =
+ W.selectAssetsNoOutputs @_ @s @k wrk w txCtx calcFee
  where
  calcFee _ = Coin.distance deposit . selectionDelta TokenBundle.getCoin
 
@@ -1669,8 +1676,9 @@ quitStakePool ctx (ApiT wid) body = do
  , txDelegationAction = Just action
  }
 
+ w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid
  sel <- liftHandler
- $ W.selectAssetsNoOutputs @_ @s @k wrk wid txCtx (const Prelude.id)
+ $ W.selectAssetsNoOutputs @_ @s @k wrk w 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.readUTxOIndex @_ @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.readUTxOIndex 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}