diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index f5270f58368..0ba0a647c63 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -102,7 +102,7 @@ module Cardano.Wallet -- ** Payment , getTxExpiry , selectAssets - , readUTxOIndex + , readWalletUTxOIndex , selectAssetsNoOutputs , assignChangeAddresses , selectionToUnsignedTx @@ -1244,17 +1244,17 @@ selectionToUnsignedTx sel s = amount = view #coin bundle assets = view #tokens bundle --- | Helper funcion for selectAssets. -readUTxOIndex +-- | 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 (WalletId, UTxOIndex, Wallet s, Set Tx) -readUTxOIndex ctx wid = do + -> ExceptT ErrNoSuchWallet IO (UTxOIndex, Wallet s, Set Tx) +readWalletUTxOIndex 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) + let utxo = UTxOIndex.fromUTxO $ availableUTxO @s pending cp + return (utxo, cp, pending) selectAssetsNoOutputs :: forall ctx s k result. @@ -1264,11 +1264,12 @@ selectAssetsNoOutputs , HasNetworkLayer ctx ) => ctx - -> (WalletId, UTxOIndex, Wallet s, Set Tx) + -> WalletId + -> (UTxOIndex, Wallet s, Set Tx) -> TransactionCtx -> (s -> SelectionResult TokenBundle -> result) -> ExceptT ErrSelectAssets IO result -selectAssetsNoOutputs ctx w@(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. @@ -1282,7 +1283,7 @@ selectAssetsNoOutputs ctx w@(wid, _, _, _) tx transform = do let dummyAddress = Address "" let dummyOutput = TxOut dummyAddress (TokenBundle.fromCoin deposit) let outs = dummyOutput :| [] - selectAssets @ctx @s @k ctx w tx outs $ \s sel -> transform s $ sel + selectAssets @ctx @s @k ctx wal tx outs $ \s sel -> transform s $ sel { outputsCovered = mempty , changeGenerated = let @@ -1318,15 +1319,13 @@ selectAssets , HasNetworkLayer ctx ) => ctx - -> (WalletId, UTxOIndex, Wallet s, Set Tx) + -> (UTxOIndex, Wallet s, Set Tx) -> TransactionCtx -> NonEmpty TxOut -> (s -> SelectionResult TokenBundle -> result) -> ExceptT ErrSelectAssets IO result -selectAssets ctx (_wid, utxo, cp, pending) tx outs transform = do - let s = getState cp - - guardWithdrawal pending +selectAssets ctx (utxo, cp, pending) tx outs transform = do + guardPendingWithdrawal pp <- liftIO $ currentProtocolParameters nl liftIO $ traceWith tr $ MsgSelectionStart utxo outs @@ -1335,7 +1334,8 @@ selectAssets ctx (_wid, utxo, cp, pending) tx outs transform = do (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 @@ -1346,9 +1346,9 @@ selectAssets ctx (_wid, utxo, cp, pending) 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 - case Set.lookupMin $ Set.filter hasWithdrawal pending' of + guardPendingWithdrawal :: ExceptT ErrSelectAssets IO () + guardPendingWithdrawal = + case Set.lookupMin $ Set.filter hasWithdrawal pending of Just pendingWithdrawal | withdrawalToCoin (txWithdrawal tx) /= Coin 0 -> throwE $ ErrSelectAssetsAlreadyWithdrawing pendingWithdrawal _otherwise -> diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 6b4b8880409..3fec6e045d0 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -1196,7 +1196,7 @@ 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 + w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid utx <- liftHandler $ W.selectAssets @_ @s @k wrk w txCtx outs transform @@ -1240,9 +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 + wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid utx <- liftHandler - $ W.selectAssetsNoOutputs @_ @s @k wrk w txCtx transform + $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx transform (_, path) <- liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid @@ -1265,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 @@ -1277,11 +1276,10 @@ 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 + wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid utx <- liftHandler - $ W.selectAssetsNoOutputs @_ @s @k wrk w 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 @@ -1438,7 +1436,7 @@ 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 + w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid sel <- liftHandler $ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id) (tx, txMeta, txTime, sealedTx) <- liftHandler @@ -1544,7 +1542,7 @@ postTransactionFee ctx (ApiT wid) body = do , txMetadata = getApiT <$> body ^. #metadata } withWorkerCtx ctx wid liftE liftE $ \wrk -> do - w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid + 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) @@ -1594,9 +1592,10 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do , txTimeToLive = ttl , txDelegationAction = Just action } - w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid + wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid sel <- liftHandler - $ W.selectAssetsNoOutputs @_ @s @k wrk w 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 @@ -1631,15 +1630,15 @@ delegationFee delegationFee ctx (ApiT wid) = do withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $ do w <- withExceptT ErrSelectAssetsNoSuchWallet $ - W.readUTxOIndex @_ @s @k wrk wid + W.readWalletUTxOIndex @_ @s @k wrk wid deposit <- W.calcMinimumDeposit @_ @s @k wrk wid mkApiFee (Just deposit) <$> W.estimateFee (runSelection wrk deposit w) where txCtx :: TransactionCtx txCtx = defaultTransactionCtx - runSelection wrk deposit w = - W.selectAssetsNoOutputs @_ @s @k wrk w txCtx calcFee + runSelection wrk deposit wal = + W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx calcFee where calcFee _ = Coin.distance deposit . selectionDelta TokenBundle.getCoin @@ -1676,9 +1675,10 @@ quitStakePool ctx (ApiT wid) body = do , txDelegationAction = Just action } - w <- liftHandler $ W.readUTxOIndex @_ @s @k wrk wid + wal <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid sel <- liftHandler - $ W.selectAssetsNoOutputs @_ @s @k wrk w 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 diff --git a/lib/shelley/bench/Restore.hs b/lib/shelley/bench/Restore.hs index 7c669296831..f6c0dc5642b 100644 --- a/lib/shelley/bench/Restore.hs +++ b/lib/shelley/bench/Restore.hs @@ -454,7 +454,7 @@ 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) - wal <- unsafeRunExceptT $ W.readUTxOIndex @_ @s @k w wid + 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 @@ -544,7 +544,7 @@ 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) - wal <- unsafeRunExceptT $ W.readUTxOIndex w wid + wal <- unsafeRunExceptT $ W.readWalletUTxOIndex w wid let runSelection = W.selectAssets @_ @s @k w wal txCtx (out :| []) getFee runExceptT $ withExceptT show $ W.estimateFee runSelection