Make fromWalletUTxO and toWalletUTxO internal

cardano-foundation · Oct 18, 2024 · aa7fe8c · aa7fe8c
1 parent 22965ac
commit aa7fe8c
Show file tree

Hide file tree

Showing 5 changed files with 100 additions and 58 deletions.
diff --git a/lib/api/cardano-wallet-api.cabal b/lib/api/cardano-wallet-api.cabal
@@ -48,6 +48,7 @@ library
     , cardano-balance-tx:{cardano-balance-tx, internal}
     , cardano-binary
     , cardano-crypto
+    , cardano-ledger-api
     , cardano-ledger-core
     , cardano-wallet
     , cardano-wallet-launcher

diff --git a/lib/api/src/Cardano/Wallet/Api/Http/Server/Error.hs b/lib/api/src/Cardano/Wallet/Api/Http/Server/Error.hs
@@ -33,6 +33,15 @@ import Prelude
 import Cardano.Address.Script
     ( Cosigner (..)
     )
+import Cardano.Ledger.Api
+    ( coinTxOutL
+    )
+import Cardano.Ledger.Api.UTxO
+    ( UTxO (..)
+    )
+import Cardano.Ledger.Coin
+    ( Coin
+    )
 import Cardano.Wallet
     ( ErrAddCosignerKey (..)
     , ErrCannotJoin (..)
@@ -213,9 +222,8 @@ import qualified Cardano.Wallet.Api.Types.Era as ApiEra
 import qualified Cardano.Wallet.Api.Types.WalletAssets as ApiWalletAssets
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
 import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
-import qualified Cardano.Wallet.Primitive.Types.UTxO as UTxO
 import qualified Cardano.Write.Eras as Write
-    ( IsRecentEra
+    ( IsRecentEra (..)
     )
 import qualified Data.Aeson as Aeson
 import qualified Data.ByteString as BS
@@ -228,9 +236,6 @@ import qualified Internal.Cardano.Write.Tx as Write
     ( serializeTx
     )
 import qualified Internal.Cardano.Write.Tx as WriteTx
-import qualified Internal.Cardano.Write.Tx.Balance as Write
-    ( toWalletUTxO
-    )
 
 instance IsServerError WalletException where
     toServerError = \case
@@ -1170,14 +1175,16 @@ instance
             , "I need an ada amount of at least:"
             , pretty (toWalletCoin (view #minimumCollateralAmount e))
             , "The largest combination of pure ada UTxOs I could find is:"
-            , pretty $ listF $ L.sort
-                $ fmap (view #coin . view #tokens . snd)
-                $ UTxO.toList
-                $ Write.toWalletUTxO
+            , pretty $ listF $ L.map show
+                $ L.sort
+                $ getCoins
                 $ view #largestCombinationAvailable e
             , "To fix this, you'll need to add one or more pure ada UTxOs"
             , "to your wallet that can cover the minimum amount required."
             ]
+      where
+        getCoins :: UTxO era -> [Coin]
+        getCoins (UTxO m) = view coinTxOutL <$> F.toList m
 
 instance IsServerError (ErrInvalidDerivationIndex 'Hardened level) where
     toServerError = \case

diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs
@@ -525,17 +525,17 @@ fromWalletUTxO
     :: forall era. IsRecentEra era
     => W.UTxO
     -> UTxO era
-fromWalletUTxO (W.UTxO m) = UTxO
-    $ Map.mapKeys Convert.toLedger
-    $ Map.map (toLedgerTxOut (recentEra @era)) m
+fromWalletUTxO = case recentEra :: RecentEra era of
+    RecentEraBabbage -> Convert.toLedgerUTxOBabbage
+    RecentEraConway -> Convert.toLedgerUTxOConway
 
 toWalletUTxO
     :: forall era. IsRecentEra era
     => UTxO era
     -> W.UTxO
-toWalletUTxO (UTxO m) = W.UTxO
-    $ Map.mapKeys Convert.toWallet
-    $ Map.map (toWalletTxOut (recentEra @era)) m
+toWalletUTxO = case recentEra :: RecentEra era of
+    RecentEraBabbage -> Convert.toWalletUTxOBabbage
+    RecentEraConway -> Convert.toWalletUTxOConway
 
 balanceTx
     :: forall era m changeState.
@@ -615,8 +615,6 @@ balanceTx
             then balanceWith SelectionStrategyMinimal
             else throwE e
   where
-    era = recentEra @era
-
     -- Creates an index of all UTxOs that are already spent as inputs of the
     -- partial transaction.
     --
@@ -634,7 +632,7 @@ balanceTx
         convertUTxO :: (TxIn, TxOut era) -> (WalletUTxO, W.TokenBundle)
         convertUTxO (i, o) = (WalletUTxO (Convert.toWallet i) addr, bundle)
           where
-            W.TxOut addr bundle = toWalletTxOut era o
+            W.TxOut addr bundle = toWalletTxOut o
         maybeUnresolvedTxIns :: Maybe (NESet TxIn)
         maybeUnresolvedTxIns =
             NESet.nonEmptySet $ txIns <\> Map.keysSet selectedUTxO
@@ -688,7 +686,7 @@ balanceTx
             Nothing -> return ()
       where
         conflicts :: UTxO era -> UTxO era -> Map TxIn (TxOut era, TxOut era)
-        conflicts = Map.conflictsWith ((/=) `on` toWalletTxOut era) `on` unUTxO
+        conflicts = Map.conflictsWith ((/=) `on` toWalletTxOut) `on` unUTxO
 
     guardRefundsResolvable :: ExceptT (ErrBalanceTx era) m ()
     guardRefundsResolvable = case stakeKeyDeposits of
@@ -1004,14 +1002,7 @@ selectAssets pp utxoAssumptions outs' redeemers
         except validateTxOutputs'
         transformSelection <$> performSelection'
   where
-    era = recentEra @era
-
-    outs = map fromLedgerTxOut outs'
-
-    fromLedgerTxOut :: TxOut era -> W.TxOut
-    fromLedgerTxOut o = case era of
-       RecentEraBabbage -> Convert.fromBabbageTxOut o
-       RecentEraConway -> Convert.fromConwayTxOut o
+    outs = map toWalletTxOut outs'
 
     validateTxOutputs'
         :: Either (ErrBalanceTx era) ()
@@ -1032,9 +1023,9 @@ selectAssets pp utxoAssumptions outs' redeemers
         , computeMinimumAdaQuantity = \addr tokens -> Convert.toWallet $
             computeMinimumCoinForTxOut
                 pp
-                (mkLedgerTxOut era addr (W.TokenBundle W.txOutMaxCoin tokens))
+                (mkLedgerTxOut addr (W.TokenBundle W.txOutMaxCoin tokens))
         , isBelowMinimumAdaQuantity = \addr bundle ->
-            isBelowMinimumCoinForTxOut pp (mkLedgerTxOut era addr bundle)
+            isBelowMinimumCoinForTxOut pp (mkLedgerTxOut addr bundle)
         , computeMinimumCost = \skeleton -> mconcat
             [ feePadding
             , fee0
@@ -1080,17 +1071,16 @@ selectAssets pp utxoAssumptions outs' redeemers
         valueOfInputs = UTxOSelection.selectedBalance utxoSelection
 
     mkLedgerTxOut
-        :: HasCallStack
-        => RecentEra era
-        -> W.Address
+        :: forall e. IsRecentEra e
+        => W.Address
         -> W.TokenBundle
-        -> TxOut era
-    mkLedgerTxOut txOutEra address bundle =
-        case txOutEra of
+        -> TxOut e
+    mkLedgerTxOut address bundle =
+        case recentEra :: RecentEra e of
             RecentEraBabbage -> Convert.toBabbageTxOut txOut
             RecentEraConway -> Convert.toConwayTxOut txOut
-          where
-            txOut = W.TxOut address bundle
+      where
+        txOut = W.TxOut address bundle
 
     txPlutusScriptExecutionCost = Convert.toWallet @W.Coin $
         if null redeemers
@@ -1355,21 +1345,18 @@ modifyShelleyTxBody txUpdate =
         UseOldTxFee -> old
 
 toLedgerTxOut
-    :: HasCallStack
-    => RecentEra era
+    :: RecentEra era
     -> W.TxOut
     -> TxOut era
 toLedgerTxOut txOutEra txOut =
     case txOutEra of
         RecentEraBabbage -> Convert.toBabbageTxOut txOut
         RecentEraConway -> Convert.toConwayTxOut txOut
 
-toWalletTxOut
-    :: RecentEra era
-    -> TxOut era
-    -> W.TxOut
-toWalletTxOut RecentEraBabbage = Convert.fromBabbageTxOut
-toWalletTxOut RecentEraConway = Convert.fromConwayTxOut
+toWalletTxOut :: forall era. IsRecentEra era => TxOut era -> W.TxOut
+toWalletTxOut o = case recentEra :: RecentEra era of
+    RecentEraBabbage -> Convert.fromBabbageTxOut o
+    RecentEraConway -> Convert.fromConwayTxOut o
 
 -- | Maps an error from the coin selection API to a balanceTx error.
 --

diff --git a/lib/primitive/lib/Cardano/Wallet/Primitive/Ledger/Convert.hs b/lib/primitive/lib/Cardano/Wallet/Primitive/Ledger/Convert.hs
@@ -48,6 +48,11 @@ module Cardano.Wallet.Primitive.Ledger.Convert
     , toConwayTxOut
     , fromBabbageTxOut
     , fromConwayTxOut
+
+    , toWalletUTxOBabbage
+    , toWalletUTxOConway
+    , toLedgerUTxOBabbage
+    , toLedgerUTxOConway
     ) where
 
 import Prelude
@@ -61,6 +66,10 @@ import Cardano.Crypto.Hash
     ( hashFromBytes
     , hashToBytes
     )
+import Cardano.Ledger.Api
+    ( Babbage
+    , Conway
+    )
 import Cardano.Slotting.Slot
     ( SlotNo (..)
     )
@@ -103,6 +112,9 @@ import Cardano.Wallet.Primitive.Types.Tx.TxIn
 import Cardano.Wallet.Primitive.Types.Tx.TxOut
     ( TxOut (..)
     )
+import Cardano.Wallet.Primitive.Types.UTxO
+    ( UTxO (..)
+    )
 import Data.ByteString.Short
     ( fromShort
     , toShort
@@ -351,8 +363,7 @@ toWalletAddress = Address . Ledger.serialiseAddr
 --------------------------------------------------------------------------------
 
 toBabbageTxOut
-    :: HasCallStack
-    => TxOut
+    :: TxOut
     -> Babbage.BabbageTxOut StandardBabbage
 toBabbageTxOut (TxOut addr bundle) =
     Babbage.BabbageTxOut
@@ -385,6 +396,34 @@ fromBabbageTxOut
 fromBabbageTxOut (Babbage.BabbageTxOut addr val _ _)
     = TxOut (toWallet addr) (toWallet val)
 
+--------------------------------------------------------------------------------
+-- Conversions for 'UTxO'
+--------------------------------------------------------------------------------
+
+toLedgerUTxOBabbage :: UTxO -> Ledger.UTxO Babbage
+toLedgerUTxOBabbage (UTxO m) = Ledger.UTxO
+    $ Map.mapKeys toLedger
+    $ Map.map toBabbageTxOut m
+
+toLedgerUTxOConway :: UTxO -> Ledger.UTxO Conway
+toLedgerUTxOConway (UTxO m) = Ledger.UTxO
+    $ Map.mapKeys toLedger
+    $ Map.map toConwayTxOut m
+
+toWalletUTxOBabbage :: Ledger.UTxO Babbage -> UTxO
+toWalletUTxOBabbage (Ledger.UTxO m) = UTxO
+    $ Map.mapKeys toWallet
+    $ Map.map fromBabbageTxOut m
+
+toWalletUTxOConway :: Ledger.UTxO Conway -> UTxO
+toWalletUTxOConway (Ledger.UTxO m) = UTxO
+    $ Map.mapKeys toWallet
+    $ Map.map fromConwayTxOut m
+
+--------------------------------------------------------------------------------
+-- Conversions for timelock and multisignature scripts
+--------------------------------------------------------------------------------
+
 toWalletScript
     :: forall era.
         ( Scripts.AllegraEraScript era
@@ -470,6 +509,10 @@ toLedgerTimelockScript s = case s of
             , show x
             ]
 
+--------------------------------------------------------------------------------
+-- Conversions for 'Delegatee'
+--------------------------------------------------------------------------------
+
 toLedgerDelegatee
     :: Maybe PoolId
     -> Maybe DRep

diff --git a/lib/wallet/src/Cardano/Wallet.hs b/lib/wallet/src/Cardano/Wallet.hs
@@ -903,9 +903,6 @@ import qualified Internal.Cardano.Write.Tx as Write
     , stakeKeyDeposit
     , toCardanoApiTx
     )
-import qualified Internal.Cardano.Write.Tx.Balance as Write
-    ( fromWalletUTxO
-    )
 
 -- $Development
 -- __Naming Conventions__
@@ -2191,9 +2188,7 @@ balanceTx
     -> IO (Write.Tx era)
 balanceTx wrk pp timeTranslation partialTx = do
     (utxo, wallet, _txs) <- liftIO $ readWalletUTxO wrk
-    let utxoIndex =
-            Write.constructUTxOIndex $
-            Write.fromWalletUTxO utxo
+    let utxoIndex = utxoIndexFromWalletUTxO utxo
 
     -- Resolve inputs using LSQ. Useful for foreign reference inputs supplied by
     -- the user when calling transactions-construct, or in transactions-balance.
@@ -2543,9 +2538,7 @@ buildTransactionPure
                 txCtx
                 (Left preSelection)
     let utxoIndex :: Write.UTxOIndex era
-        utxoIndex =
-            Write.constructUTxOIndex $
-            Write.fromWalletUTxO utxo
+        utxoIndex = utxoIndexFromWalletUTxO utxo
     withExceptT Left $
         Write.balanceTx @_ @_ @s
             pparams
@@ -3238,8 +3231,7 @@ transactionFee DBLayer{atomically, walletState} protocolParams
             -- strict, and each field is defined in terms of 'Data.Map.Strict'.
             --
             evaluate
-                $ Write.constructUTxOIndex
-                $ Write.fromWalletUTxO
+                $ utxoIndexFromWalletUTxO
                 $ availableUTxO mempty wallet
         unsignedTxBody <- wrapErrMkTransaction $
             mkUnsignedTransaction
@@ -3692,6 +3684,18 @@ normalizeSharedAddress st addr = case Shared.ready st of
             _ ->
                 pure $ Shared.liftPaymentAddress @n fingerprint
 
+{-------------------------------------------------------------------------------
+                                   Helpers
+-------------------------------------------------------------------------------}
+
+utxoIndexFromWalletUTxO
+    :: forall era. Write.IsRecentEra era => UTxO -> Write.UTxOIndex era
+utxoIndexFromWalletUTxO utxo =
+    Write.constructUTxOIndex
+    $ case Write.recentEra :: Write.RecentEra era of
+        Write.RecentEraBabbage -> Convert.toLedgerUTxOBabbage utxo
+        Write.RecentEraConway -> Convert.toLedgerUTxOConway utxo
+
 {-------------------------------------------------------------------------------
                                    Errors
 -------------------------------------------------------------------------------}