Separate resolveTx and make fee selection less hacky

uhbif19 · Jun 19, 2024 · f55a5b2 · f55a5b2
1 parent c24ea0b
commit f55a5b2
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 17 deletions.
diff --git a/src/Cardano/CEM/Monads/L1Commons.hs b/src/Cardano/CEM/Monads/L1Commons.hs
@@ -25,8 +25,14 @@ cardanoTxBodyFromResolvedTx ::
   m (Either (TxBodyErrorAutoBalance Era) (TxBody Era, TxInMode))
 cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
   -- (lowerBound, upperBound) <- convertValidityBound validityBound
-  -- FIXME
-  let keyWitnessedTxIns = [fst $ last txIns]
+
+  -- FIXME: proper fee coverage selection
+  utxo <- queryUtxo $ ByAddresses [signingKeyToAddress signer]
+  let
+    feeTxIns = Map.keys $ unUTxO utxo
+    allTxIns = txIns ++ map withKeyWitness feeTxIns
+
+  signerAddress <- fromPlutusAddressInMonad $ signingKeyToAddress signer
   MkBlockchainParams {protocolParameters} <- queryBlockchainParams
 
   let additionalSignersKeys =
@@ -35,9 +41,9 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
   let preBody =
         TxBodyContent
           { -- FIXME: duplicate TxIn for coin-selection redeemer bug
-            txIns = nub txIns
+            txIns = nub allTxIns
           , txInsCollateral =
-              TxInsCollateral AlonzoEraOnwardsBabbage keyWitnessedTxIns
+              TxInsCollateral AlonzoEraOnwardsBabbage feeTxIns
           , txInsReference =
               TxInsReference BabbageEraOnwardsBabbage txInsReference
           , txOuts
@@ -46,8 +52,8 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
             -- signatures
             txExtraKeyWits =
               TxExtraKeyWitnesses AlonzoEraOnwardsBabbage $
-                fmap (verificationKeyHash . getVerificationKey) $
-                  additionalSignersKeys
+                verificationKeyHash . getVerificationKey
+                  <$> additionalSignersKeys
           , txProtocolParams =
               BuildTxWith $
                 Just $
@@ -71,8 +77,7 @@ cardanoTxBodyFromResolvedTx (MkResolvedTx {..}) = do
           , txVotingProcedures = Nothing
           }
 
-  signerAddress <- fromPlutusAddressInMonad $ signingKeyToAddress signer
-  txInsUtxo <- queryUtxo $ ByTxIns $ map fst txIns
+  txInsUtxo <- queryUtxo $ ByTxIns $ map fst allTxIns
 
   runExceptT $ do
     body <-

diff --git a/src/Cardano/CEM/OffChain.hs b/src/Cardano/CEM/OffChain.hs
@@ -241,11 +241,11 @@ resolveAction
             convertTxOut x =
               TxOutValueShelleyBased shelleyBasedEra $ toMaryValue x
 
-resolveTxAndSubmit ::
+resolveTx ::
   (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) =>
   TxSpec ->
-  m (Either TxResolutionError TxId)
-resolveTxAndSubmit spec = runExceptT $ do
+  m (Either TxResolutionError ResolvedTx)
+resolveTx spec = runExceptT $ do
   -- Get specs
   !actionsSpecs <- mapM (ExceptT . resolveAction) $ actions spec
 
@@ -254,9 +254,13 @@ resolveTxAndSubmit spec = runExceptT $ do
     mergedSpec' = head actionsSpecs
     mergedSpec = mergedSpec' {signer = specSigner spec}
 
-  -- FIXME: more robust fee covering
-  !utxo <-
-    lift $ queryUtxo $ ByAddresses [signingKeyToAddress $ signer mergedSpec]
-  let ins = map withKeyWitness $ Map.keys $ unUTxO utxo
-  let result = submitResolvedTx $ mergedSpec {txIns = txIns mergedSpec ++ ins}
-  ExceptT $ (bimap UnhandledSubmittingError id) <$> result
+  return mergedSpec
+
+resolveTxAndSubmit ::
+  (MonadQueryUtxo m, MonadSubmitTx m, MonadIO m) =>
+  TxSpec ->
+  m (Either TxResolutionError TxId)
+resolveTxAndSubmit spec = runExceptT $ do
+  resolved <- ExceptT $ resolveTx spec
+  let result = submitResolvedTx resolved
+  ExceptT $ first UnhandledSubmittingError <$> result