Try #3553:

lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs

@@ -207,7 +207,7 @@ import Cardano.Wallet.Api.Types
  , ApiAsArray (..)
  , ApiAsset (..)
  , ApiAssetMintBurn (..)
- , ApiBalanceTransactionPostData
+ , ApiBalanceTransactionPostData (..)
  , ApiBlockInfo (..)
  , ApiBlockReference (..)
  , ApiBurnData (..)
@@ -329,7 +329,11 @@ import Cardano.Wallet.Api.Types.MintBurn
 import Cardano.Wallet.Api.Types.SchemaMetadata
  ( TxMetadataSchema (..), TxMetadataWithSchema (TxMetadataWithSchema) )
 import Cardano.Wallet.CoinSelection
- ( SelectionOf (..), SelectionStrategy (..), selectionDelta )
+ ( PreSelection (..)
+ , SelectionOf (..)
+ , SelectionStrategy (..)
+ , selectionDelta
+ )
 import Cardano.Wallet.Compat
  ( (^?) )
 import Cardano.Wallet.DB
@@ -2231,7 +2235,9 @@ constructTransaction
  -> ApiT WalletId
  -> ApiConstructTransactionData n
  -> Handler (ApiConstructTransaction n)
-constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do
+constructTransaction
+ ctx genChange knownPools getPoolStatus apiw@(ApiT wid) body = do
+
  let isNoPayload =
  isNothing (body ^. #payments) &&
  isNothing (body ^. #withdrawal) &&
@@ -2353,15 +2359,7 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do
  , txValidityInterval = (Just before, hereafter)
  , txDelegationAction = Just action
  })
- let transform s sel =
- ( W.assignChangeAddresses genChange sel s
- & uncurry (W.selectionToUnsignedTx (txWithdrawal txCtx))
- , sel
- , selectionDelta TokenBundle.getCoin sel
- )
 
- (utxoAvailable, wallet, pendingTxs) <-
- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
  (txCtx', policyXPubM) <-
  if isJust mintingBurning' then do
  (policyXPub, _) <-
@@ -2414,63 +2412,125 @@ constructTransaction ctx genChange knownPools getPoolStatus (ApiT wid) body = do
  else
  pure (txCtx, Nothing)
 
- let runSelection outs =
- W.selectAssets @_ @_ @s @k @'CredFromKeyK
- wrk era pp selectAssetsParams transform
- where
- selectAssetsParams = W.SelectAssetsParams
- { outputs = outs
- , pendingTxs
- , randomSeed = Nothing
- , txContext = txCtx'
- , utxoAvailableForInputs =
- UTxOSelection.fromIndex utxoAvailable
- , utxoAvailableForCollateral =
- UTxOIndex.toMap utxoAvailable
- , wallet
- , selectionStrategy = SelectionStrategyOptimal
- }
-
- (sel, sel', fee) <- do
- outs <- case (body ^. #payments) of
- Nothing -> pure []
- Just (ApiPaymentAddresses content) ->
- pure $ F.toList (addressAmountToTxOut <$> content)
-
- let mintWithAddress
- (ApiMintBurnData _ _ (ApiMint (ApiMintData (Just _) _)))
- = True
- mintWithAddress _ = False
- let mintingOuts = case mintingBurning' of
- Just mintBurns ->
- coalesceTokensPerAddr $
- map (toMintTxOut (fromJust policyXPubM)) $
- filter mintWithAddress $
- NE.toList mintBurns
- Nothing -> []
-
- (sel', utx, fee') <- liftHandler $
- runSelection (outs ++ mintingOuts)
- sel <- liftHandler $
- W.assignChangeAddressesWithoutDbUpdate wrk wid genChange utx
- (FeeEstimation estMin _) <- liftHandler $ W.estimateFee (pure fee')
- pure (sel, sel', estMin)
+ outs <- case (body ^. #payments) of
+ Nothing -> pure []
+ Just (ApiPaymentAddresses content) ->
+ pure $ F.toList (addressAmountToTxOut <$> content)
+
+ let mintWithAddress
+ (ApiMintBurnData _ _ (ApiMint (ApiMintData (Just _) _)))
+ = True
+ mintWithAddress _ = False
+ let mintingOuts = case mintingBurning' of
+ Just mintBurns ->
+ coalesceTokensPerAddr $
+ map (toMintTxOut (fromJust policyXPubM)) $
+ filter mintWithAddress $
+ NE.toList mintBurns
+ Nothing -> []
+
+ let preSel = PreSelection
+ { outputs = outs ++ mintingOuts
+ , assetsToMint = fst $ txCtx' ^. #txAssetsToMint
+ , assetsToBurn = fst $ txCtx' ^. #txAssetsToBurn
+ , extraCoinSource = fromMaybe (Coin 0)refund
+ , extraCoinSink = fromMaybe (Coin 0) deposit
+ }
+ unbalancedTx <- liftHandler $
+ W.constructTransaction @_ @s @k @n wrk wid era txCtx' (Left preSel)
+
+ let balancedPostData = ApiBalanceTransactionPostData
+ { transaction = ApiT unbalancedTx
+ , inputs = []
+ , redeemers = []
+ , encoding = body ^. #encoding
+ }
+ balancedTx <- balanceTransaction
+ ctx genChange (ApiT wid) balancedPostData
+ apiDecoded <- decodeTransaction @_ @s @k @n ctx apiw balancedTx
 
- tx <- liftHandler
- $ W.constructTransaction @_ @s @k @n wrk wid era txCtx' sel
+ (_, _, rewardPath) <-
+ liftHandler $ W.readRewardAccount @_ @s @k @n wrk wid
 
  pure $ ApiConstructTransaction
- { transaction = case body ^. #encoding of
- Just HexEncoded -> ApiSerialisedTransaction (ApiT tx) HexEncoded
- _ -> ApiSerialisedTransaction (ApiT tx) Base64Encoded
+ { transaction = balancedTx
  , coinSelection = mkApiCoinSelection
- (maybeToList deposit) (maybeToList refund) Nothing md sel'
- , fee = Quantity $ fromIntegral fee
+ (maybe [] singleton deposit)
+ (maybe [] singleton refund)
+ ((,rewardPath) <$> txCtx' ^. #txDelegationAction)
+ md
+ (unsignedTx rewardPath (outs ++ mintingOuts) apiDecoded)
+ , fee = apiDecoded ^. #fee
  }
  where
  ti :: TimeInterpreter (ExceptT PastHorizonException IO)
  ti = timeInterpreter (ctx ^. networkLayer)
 
+ singleton x = [x]
+
+ toUnsignedTxChange initialOuts = \case
+ WalletOutput o ->
+ let address = getApiT (fst (o ^. #address))
+ derivationPath = fmap getApiT (o ^. #derivationPath)
+ coin = Coin.fromQuantity (o ^. #amount)
+ assets = getApiT (o ^. #assets)
+ txChange = TxChange address coin assets derivationPath
+ txOut = TxOut address (TokenBundle coin assets)
+ in
+ if txOut `L.notElem` initialOuts then Just txChange else Nothing
+ ExternalOutput _ ->
+ Nothing
+
+ toUnsignedTxOut initialOuts = \case
+ WalletOutput o ->
+ let address = getApiT (fst (o ^. #address))
+ coin = Coin.fromQuantity (o ^. #amount)
+ assets = getApiT (o ^. #assets)
+ txOut = TxOut address (TokenBundle coin assets)
+ in
+ if txOut `L.elem` initialOuts then Just txOut else Nothing
+ ExternalOutput o ->
+ let address = getApiT (fst (o ^. #address))
+ coin = Coin.fromQuantity (o ^. #amount)
+ assets = getApiT (o ^. #assets)
+ txOut = TxOut address (TokenBundle coin assets)
+ in
+ if txOut `L.elem` initialOuts then Just txOut else Nothing
+
+ toUsignedTxWdrl p = \case
+ ApiWithdrawalGeneral (ApiT rewardAcc, _) amount Our ->
+ Just (rewardAcc, Coin.fromQuantity amount, p)
+ ApiWithdrawalGeneral _ _ External ->
+ Nothing
+
+ toUnsignedTxInp = \case
+ WalletInput i ->
+ let txId = getApiT (i ^. #id)
+ index = i ^. #index
+ address = getApiT (fst (i ^. #address))
+ derivationPath = fmap getApiT (i ^. #derivationPath)
+ coin = Coin.fromQuantity (i ^. #amount)
+ assets = getApiT (i ^. #assets)
+ txIn = TxIn txId index
+ txOut = TxOut address (TokenBundle coin assets)
+ in
+ Just (txIn, txOut, derivationPath)
+ ExternalInput _ ->
+ Nothing
+
+ unsignedTx path initialOuts decodedTx = UnsignedTx
+ { unsignedCollateral =
+ mapMaybe toUnsignedTxInp (decodedTx ^. #collateral)
+ , unsignedInputs =
+ mapMaybe toUnsignedTxInp (decodedTx ^. #inputs)
+ , unsignedOutputs =
+ mapMaybe (toUnsignedTxOut initialOuts) (decodedTx ^. #outputs)
+ , unsignedChange =
+ mapMaybe (toUnsignedTxChange initialOuts) (decodedTx ^. #outputs)
+ , unsignedWithdrawals =
+ mapMaybe (toUsignedTxWdrl path) (decodedTx ^. #withdrawals)
+ }
+
  toMintTxOut policyXPub
  (ApiMintBurnData (ApiT scriptT) (Just (ApiT tName))
  (ApiMint (ApiMintData (Just addr) amt))) =
@@ -2728,8 +2788,8 @@ decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _
  }
 
 balanceTransaction
- :: forall ctx s k (n :: NetworkDiscriminant).
- ( ctx ~ ApiLayer s k 'CredFromKeyK
+ :: forall ctx s k ktype (n :: NetworkDiscriminant).
+ ( ctx ~ ApiLayer s k ktype
  , HasNetworkLayer IO ctx
  , GenChange s
  , BoundedAddressLength k
@@ -2800,7 +2860,7 @@ balanceTransaction ctx genChange (ApiT wid) body = do
  => W.PartialTx era
  -> Handler (Cardano.Tx era)
  balanceTx partialTx =
- liftHandler $ W.balanceTransaction @_ @IO @s @k @'CredFromKeyK
+ liftHandler $ W.balanceTransaction @_ @IO @s @k @ktype
  wrk
  genChange
  (pp, nodePParams)

lib/wallet/integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs

@@ -416,7 +416,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do
  verify rTx
  [ expectResponseCode HTTP.status202
  , expectField (#coinSelection . #metadata) (`shouldBe` Nothing)
- , expectField (#coinSelection . #withdrawals) (`shouldSatisfy` (not . null))
+ , expectField (#coinSelection . #withdrawals) (`shouldSatisfy` null)
  ]
  let expectedFee = getFromResponse (#fee . #getQuantity) rTx
 

lib/wallet/src/Cardano/Wallet.hs

@@ -238,7 +238,8 @@ import Cardano.Wallet.Checkpoints
  , sparseCheckpoints
  )
 import Cardano.Wallet.CoinSelection
- ( Selection
+ ( PreSelection
+ , Selection
  , SelectionBalanceError (..)
  , SelectionCollateralRequirement (..)
  , SelectionConstraints (..)
@@ -2534,7 +2535,7 @@ constructTransaction
  -> WalletId
  -> Cardano.AnyCardanoEra
  -> TransactionCtx
- -> SelectionOf TxOut
+ -> Either PreSelection (SelectionOf TxOut)
  -> ExceptT ErrConstructTx IO SealedTx
 constructTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do
  (_, xpub, _) <- withExceptT ErrConstructTxReadRewardAccount $
@@ -2596,7 +2597,7 @@ constructSharedTransaction ctx wid era txCtx sel = db & \DBLayer{..} -> do
  mapExceptT atomically $ do
  pp <- liftIO $ currentProtocolParameters nl
  withExceptT ErrConstructTxBody $ ExceptT $ pure $
- mkUnsignedTransaction tl era xpub pp txCtx' sel
+ mkUnsignedTransaction tl era xpub pp txCtx' (Right sel)
  where
  db = ctx ^. dbLayer @IO @s @k
  tl = ctx ^. transactionLayer @k @'CredFromScriptK

lib/wallet/src/Cardano/Wallet/CoinSelection.hs

@@ -50,6 +50,7 @@ module Cardano.Wallet.CoinSelection
  , SelectionOf (..)
  , SelectionParams (..)
  , SelectionStrategy (..)
+ , PreSelection (..)
 
  -- * Selection skeletons
  , SelectionSkeleton (..)
@@ -384,6 +385,28 @@ toExternalSelectionSkeleton Internal.SelectionSkeleton {..} =
 -- Selections
 --------------------------------------------------------------------------------
 
+-- | Represents a unbalanced selection.
+--
+data PreSelection = PreSelection
+ { outputs
+ :: ![TxOut]
+ -- ^ User-specified outputs
+ , assetsToMint
+ :: !TokenMap
+ -- ^ Assets to mint.
+ , assetsToBurn
+ :: !TokenMap
+ -- ^ Assets to burn.
+ , extraCoinSource
+ :: !Coin
+ -- ^ An extra source of ada.
+ , extraCoinSink
+ :: !Coin
+ -- ^ An extra sink for ada.
+ }
+ deriving (Generic, Eq, Show)
+
+
 -- | Represents a balanced selection.
 --
 data SelectionOf change = Selection