Add witness map to tx build (#121) (#122)

* Add witness map to tx build

* Add a test for the index lookup function

* Add reference inputs

changelog.md

@@ -12,6 +12,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 - Move `Convex.BuildTx` and `Convex.CoinSelection.CardanoAPI` from `convex-coin-selection` to `convex-base`
 - Rename `Convex.CoinSelection.CardanoAPI` to `Convex.CoinSelection`
 * When selecting public-key UTxOs during coin selection, outputs that are incompatible with PlutusV1 scripts are excluded.
+* Fixed a bug in coin selection where the wallet's mixed inputs were not considered for a `TxBodyContent` with zero inputs
+* `Convex.BuildTx`: Added the option to look at all of a transaction's inputs when building a transaction
+
 - Added a `Tracer m TxBalancingMessage` argument to the coin selection functions. This prints out useful information about decisions taken during coin selection and balancing. Instantiate with `mempty` to ignore the messages.
 - Changed the `protocolParameters`, `ledgerProtocolParameters` lenses in `Convex.NodeParams` to update the other field too (making sure they are always in sync)
 - Export `Convex.Wallet.MockWallet.w4`

src/base/lib/Convex/BuildTx.hs

@@ -1,52 +1,74 @@
 {-# LANGUAGE DataKinds            #-}
 {-# LANGUAGE DerivingStrategies   #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE NamedFieldPuns       #-}
 {-# LANGUAGE NumericUnderscores   #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns         #-}
 {-| Building transactions
 -}
 module Convex.BuildTx(
+  -- * Tx Builder
+  TxBuilder(..),
+  -- ** Looking at transaction inputs
+  TransactionInputs(..),
+  lookupIndexSpending,
+  lookupIndexReference,
+  findIndexSpending,
+  findIndexReference,
+  buildTx,
+  buildTxWith,
   -- * Effect
   MonadBuildTx(..),
   BuildTxT(..),
+  addBtx,
   runBuildTxT,
   runBuildTx,
   execBuildTxT,
   execBuildTx,
   execBuildTx',
   evalBuildTxT,
 
-  TxBuild,
   -- * Building transactions
+  addInput,
+  addReference,
+  addCollateral,
+  addAuxScript,
+  prependTxOut,
+  addOutput,
+  setScriptsValid,
+  addRequiredSignature,
+
+  -- ** Variations of @addInput@
   spendPublicKeyOutput,
-  payToAddress,
-  payToAddressTxOut,
-  payToPublicKey,
-  payToScriptHash,
-  payToPlutusV1,
-  payToPlutusV2,
-  payToPlutusV2InlineDatum,
   spendPlutusV1,
   spendPlutusV2,
   spendPlutusV2Ref,
   spendPlutusV2RefWithInlineDatum,
   spendPlutusV2RefWithoutInRef,
   spendPlutusV2RefWithoutInRefInlineDatum,
   spendPlutusV2InlineDatum,
-  mintPlutusV1,
-  mintPlutusV2,
-  mintPlutusV2Ref,
+
+  -- ** Adding outputs
+  payToAddress,
+  payToAddressTxOut,
+  payToPublicKey,
+  payToScriptHash,
+  payToPlutusV1,
+  payToPlutusV2,
+  payToPlutusV2InlineDatum,
   payToPlutusV2Inline,
   payToPlutusV2InlineWithInlineDatum,
   payToPlutusV2InlineWithDatum,
-  addReference,
-  addCollateral,
-  addAuxScript,
+
+  -- ** Minting and burning tokens
+  mintPlutusV1,
+  mintPlutusV2,
+  mintPlutusV2Ref,
+
+  -- ** Utilities
   assetValue,
-  setScriptsValid,
-  addRequiredSignature,
-  prependTxOut,
+
   -- * Minimum Ada deposit
   minAdaDeposit,
   setMinAdaDeposit,
@@ -56,10 +78,13 @@ module Convex.BuildTx(
 import           Cardano.Api.Shelley        (Hash, NetworkId, PaymentKey,
                                              PlutusScript, PlutusScriptV1,
                                              PlutusScriptV2, ScriptData,
-                                             ScriptHash)
+                                             ScriptHash, TxBodyContent (..),
+                                             WitCtxTxIn, Witness)
 import qualified Cardano.Api.Shelley        as C
 import qualified Cardano.Ledger.Core        as CLedger
-import           Control.Lens               (_1, _2, at, mapped, over, set, (&))
+import           Control.Lens               (_1, _2, at, mapped, over, set,
+                                             view, (&))
+import qualified Control.Lens               as L
 import           Control.Monad.Except       (MonadError (..))
 import qualified Control.Monad.State        as LazyState
 import           Control.Monad.State.Class  (MonadState (..))
@@ -78,55 +103,123 @@ import           Convex.MonadLog            (MonadLog (..), MonadLogIgnoreT,
 import           Convex.Scripts             (toScriptData)
 import           Data.Functor.Identity      (Identity (..))
 import           Data.List                  (nub)
+import           Data.Map                   (Map)
 import qualified Data.Map                   as Map
 import           Data.Maybe                 (fromMaybe)
+import           Data.Set                   (Set)
+import qualified Data.Set                   as Set
 import qualified Plutus.V1.Ledger.Api       as Plutus
 
-newtype BTX = BTX{ unBtx :: C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra }
+{-| A map of all inputs of the final transaction produced by a @TxBuilder@
+-}
+-- TOOO: This is essentially a subset of @TxBodyContent BuildTx@. Maybe we should
+--       just make the entire @TxBodyContent BuildTx@ available to 'addInput'?
+data TransactionInputs = TransactionInputs
+  { txiSpendingInputs  :: Map C.TxIn (Witness WitCtxTxIn C.BabbageEra) -- ^ Inputs spent by the final transaction
+  , txiReferenceInputs :: Set C.TxIn -- ^ Reference inputs used by the final transaction
+  }
+
+mkTxInputs :: C.TxBodyContent C.BuildTx C.BabbageEra -> TransactionInputs
+mkTxInputs TxBodyContent{txIns, txInsReference} =
+  TransactionInputs
+    { txiSpendingInputs  = Map.fromList (fmap (view L._BuildTxWith) <$> txIns)
+    , txiReferenceInputs = Set.fromList (view L._TxInsReference txInsReference)
+    }
+
+{-| Look up the index of the @TxIn@ in the list of spending inputs
+-}
+lookupIndexSpending :: C.TxIn -> TransactionInputs -> Maybe Int
+lookupIndexSpending txi = Map.lookupIndex txi . txiSpendingInputs
+
+{-| Look up the index of the @TxIn@ in the list of reference inputs
+-}
+lookupIndexReference :: C.TxIn -> TransactionInputs -> Maybe Int
+lookupIndexReference txi = Set.lookupIndex txi . txiReferenceInputs
+
+{-| Look up the index of the @TxIn@ in the list of spending inputs
+-}
+findIndexSpending :: C.TxIn -> TransactionInputs -> Int
+findIndexSpending txi = Map.findIndex txi . txiSpendingInputs
+
+{-| Look up the index of the @TxIn@ in the list of reference inputs
+-}
+findIndexReference :: C.TxIn -> TransactionInputs -> Int
+findIndexReference txi = Set.findIndex txi . txiReferenceInputs
+
+{-| A function that modifies the @TxBodyContent@, after seeing the inputs of
+the entire finished transaction (lazily).
+
+Note that the result of @unTxBuilder inputs@ must not depend on the entirety of
+@inputs@. For example, using this to construct a redeemer that contains the whole
+@TransactionInputs@ map is going to loop forever. However, it is fine to look
+at all the keys of the map, and at individual values of the map.
+-}
+newtype TxBuilder = TxBuilder{ unTxBuilder :: TransactionInputs -> C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra }
+
+{-| Construct the final @TxBodyContent@
+-}
+buildTx :: TxBuilder -> C.TxBodyContent C.BuildTx C.BabbageEra
+buildTx txb = buildTxWith txb L.emptyTx
 
-instance Semigroup BTX where
+{-| Construct the final @TxBodyContent@ from the provided @TxBodyContent@
+-}
+buildTxWith :: TxBuilder -> C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra
+buildTxWith TxBuilder{unTxBuilder} initial =
+  let mp :: TransactionInputs
+      mp = mkTxInputs result
+      result = unTxBuilder mp initial
+  in result
+
+instance Semigroup TxBuilder where
     -- note that the order here is reversed, compared to @Data.Monoid.Endo@.
     -- This is so that @addBtx a >> addBtx b@ will result in a transaction
     -- where @a@ has been applied before @b@.
-  (BTX l) <> (BTX r) = BTX (r . l)
+  (TxBuilder l) <> (TxBuilder r) = TxBuilder $ \k -> (r k . l k)
 
-instance Monoid BTX where
-  mempty = BTX id
+instance Monoid TxBuilder where
+  mempty = TxBuilder $ const id
 
+{-| An effect that collects @TxBuilder@ values for building
+cardano transactions
+-}
 class Monad m => MonadBuildTx m where
-  addBtx :: TxBuild -> m ()
+  -- | Add a @TxBuilder@
+  addTxBuilder :: TxBuilder -> m ()
 
 instance MonadBuildTx m => MonadBuildTx (ExceptT e m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance MonadBuildTx m => MonadBuildTx (StrictState.StateT e m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance MonadBuildTx m => MonadBuildTx (LazyState.StateT e m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance (Monoid w, MonadBuildTx m) => MonadBuildTx (WriterT w m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance MonadBuildTx m => MonadBuildTx (MonadBlockchainCardanoNodeT e m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance MonadBuildTx m => MonadBuildTx (MonadLogIgnoreT m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
 
 instance MonadBuildTx m => MonadBuildTx (MonadLogKatipT m) where
-  addBtx = lift . addBtx
+  addTxBuilder = lift . addTxBuilder
+
+addBtx :: MonadBuildTx m => (C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra) -> m ()
+addBtx = addTxBuilder . TxBuilder . const
 
 {-| Monad transformer for the @MonadBuildTx@ effect
 -}
-newtype BuildTxT m a = BuildTxT{unBuildTxT :: WriterT BTX m a }
+newtype BuildTxT m a = BuildTxT{unBuildTxT :: WriterT TxBuilder m a }
   deriving newtype (Functor, Applicative, Monad)
 
 instance MonadTrans BuildTxT where
   lift = BuildTxT . lift
 
 instance Monad m => MonadBuildTx (BuildTxT m) where
-  addBtx = BuildTxT . tell . BTX
+  addTxBuilder = BuildTxT . tell
 
 instance MonadError e m => MonadError e (BuildTxT m) where
   throwError = lift . throwError
@@ -157,31 +250,37 @@ instance MonadLog m => MonadLog (BuildTxT m) where
 
 {-| Run the @BuildTxT@ monad transformer
 -}
-runBuildTxT :: Functor m => BuildTxT m a -> m (a, TxBuild)
-runBuildTxT = fmap (fmap unBtx) . runWriterT . unBuildTxT
+runBuildTxT :: BuildTxT m a -> m (a, TxBuilder)
+runBuildTxT = runWriterT . unBuildTxT
 
 {-| Run the @BuildTxT@ monad transformer, returning the @TxBuild@ part only
 -}
-execBuildTxT :: Monad m => BuildTxT m a -> m TxBuild
-execBuildTxT = fmap unBtx . execWriterT . unBuildTxT
+execBuildTxT :: Monad m => BuildTxT m a -> m TxBuilder
+execBuildTxT = execWriterT . unBuildTxT
 
 {-| Run the @BuildTxT@ monad transformer, returnin only the result
 -}
 evalBuildTxT :: Monad m => BuildTxT m a -> m a
 evalBuildTxT = fmap fst . runWriterT . unBuildTxT
 
-runBuildTx :: BuildTxT Identity a -> (a, TxBuild)
+runBuildTx :: BuildTxT Identity a -> (a, TxBuilder)
 runBuildTx = runIdentity . runBuildTxT
 
-execBuildTx :: BuildTxT Identity a -> TxBuild
+execBuildTx :: BuildTxT Identity a -> TxBuilder
 execBuildTx = runIdentity . execBuildTxT
 
 {-| Run the @BuildTx@ action and produce a transaction body
 -}
 execBuildTx' :: BuildTxT Identity a -> C.TxBodyContent C.BuildTx C.BabbageEra
-execBuildTx' = flip ($) L.emptyTx . runIdentity . execBuildTxT
+execBuildTx' = buildTx . runIdentity . execBuildTxT
 
-type TxBuild = C.TxBodyContent C.BuildTx C.BabbageEra -> C.TxBodyContent C.BuildTx C.BabbageEra
+{-| Spend an UTxO using the given witness. To avoid an infinite loop when
+constructing the witness, make sure that the witness does not depend on
+itself. For example, @addInput txi (\mp -> Map.lookup txi mp)@ is going
+to loop.
+-}
+addInput :: MonadBuildTx m => C.TxIn -> (TransactionInputs -> Witness WitCtxTxIn C.BabbageEra) -> m ()
+addInput txIn f = addTxBuilder (TxBuilder $ \lkp -> (over L.txIns ((txIn, C.BuildTxWith $ f lkp) :)))
 
 {-| Spend an output locked by a public key
 -}
@@ -210,16 +309,16 @@ spendPlutusV2InlineDatum txIn s (toScriptData -> red) =
       wit' = C.BuildTxWith (C.ScriptWitness C.ScriptWitnessForSpending wit)
   in setScriptsValid >> addBtx (over L.txIns ((txIn, wit') :))
 
-spendPlutusV2RefBase :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> redeemer -> m ()
-spendPlutusV2RefBase txIn refTxIn sh dat (toScriptData -> red) =
-  let wit = C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 (C.PReferenceScript refTxIn sh) dat red (C.ExecutionUnits 0 0)
-      wit' = C.BuildTxWith (C.ScriptWitness C.ScriptWitnessForSpending wit)
-  in setScriptsValid >> addBtx (over L.txIns ((txIn, wit') :))
+spendPlutusV2RefBase :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> (Int -> redeemer) -> m ()
+spendPlutusV2RefBase txIn refTxIn sh dat red =
+  let wit lkp = C.PlutusScriptWitness C.PlutusScriptV2InBabbage C.PlutusScriptV2 (C.PReferenceScript refTxIn sh) dat (toScriptData $ red $ findIndexSpending txIn lkp) (C.ExecutionUnits 0 0)
+      wit' = C.BuildTxWith . C.ScriptWitness C.ScriptWitnessForSpending . wit
+  in setScriptsValid >> addTxBuilder (TxBuilder $ \lkp -> over L.txIns ((txIn, wit' lkp) :))
 
-{-| same as spendPlutusV2RefBase but adds the reference script in the reference input list
+{-| Spend an output locked by a Plutus V2 validator using the redeemer
 -}
 spendPlutusV2RefBaseWithInRef :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> C.ScriptDatum C.WitCtxTxIn -> redeemer -> m ()
-spendPlutusV2RefBaseWithInRef txIn refTxIn sh dat red = spendPlutusV2RefBase txIn refTxIn sh dat red >> addReference refTxIn
+spendPlutusV2RefBaseWithInRef txIn refTxIn sh dat red = spendPlutusV2RefBase txIn refTxIn sh dat (const red) >> addReference refTxIn
 
 spendPlutusV2Ref :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> datum -> redeemer -> m ()
 spendPlutusV2Ref txIn refTxIn sh (toScriptData -> dat) red = spendPlutusV2RefBaseWithInRef txIn refTxIn sh (C.ScriptDatumForTxIn dat) red
@@ -233,13 +332,12 @@ spendPlutusV2RefWithInlineDatum txIn refTxIn sh red = spendPlutusV2RefBaseWithIn
 This is to cover the case whereby the reference script utxo is expected to be consumed in the same tx.
 -}
 spendPlutusV2RefWithoutInRef :: forall datum redeemer m. (MonadBuildTx m, Plutus.ToData datum, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> datum -> redeemer -> m ()
-spendPlutusV2RefWithoutInRef txIn refTxIn sh (toScriptData -> dat) red = spendPlutusV2RefBase txIn refTxIn sh (C.ScriptDatumForTxIn dat) red
+spendPlutusV2RefWithoutInRef txIn refTxIn sh (toScriptData -> dat) red = spendPlutusV2RefBase txIn refTxIn sh (C.ScriptDatumForTxIn dat) (const red)
 
 {-| same as spendPlutusV2RefWithoutInRef but considers inline datum at the spent utxo
 -}
 spendPlutusV2RefWithoutInRefInlineDatum :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => C.TxIn -> C.TxIn -> Maybe C.ScriptHash -> redeemer -> m ()
-spendPlutusV2RefWithoutInRefInlineDatum txIn refTxIn sh red = spendPlutusV2RefBase txIn refTxIn sh C.InlineScriptDatum red
-
+spendPlutusV2RefWithoutInRefInlineDatum txIn refTxIn sh red = spendPlutusV2RefBase txIn refTxIn sh C.InlineScriptDatum (const red)
 
 mintPlutusV1 :: forall redeemer m. (MonadBuildTx m, Plutus.ToData redeemer) => PlutusScript PlutusScriptV1 -> redeemer -> C.AssetName -> C.Quantity -> m ()
 mintPlutusV1 script (toScriptData -> red) assetName quantity =
@@ -356,6 +454,9 @@ setMinAdaDeposit params txOut =
   let minUtxo = minAdaDeposit params txOut
   in txOut & over (L._TxOut . _2 . L._TxOutValue . L._Value . at C.AdaAssetId) (maybe (Just minUtxo) (Just . max minUtxo))
 
+{-| Calculate the minimum amount of Ada that must be locked in the given UTxO to
+satisfy the ledger's minimum Ada constraint.
+-}
 minAdaDeposit :: CLedger.PParams (C.ShelleyLedgerEra C.BabbageEra) -> C.TxOut C.CtxTx C.BabbageEra -> C.Quantity
 minAdaDeposit params txOut =
   let minAdaValue = C.Quantity 3_000_000
@@ -383,3 +484,8 @@ addRequiredSignature sig =
 -}
 prependTxOut :: MonadBuildTx m => C.TxOut C.CtxTx C.BabbageEra -> m ()
 prependTxOut txOut = addBtx (over L.txOuts ((:) txOut))
+
+{-| Add a transaction output to the end of the list of transaction outputs.
+-}
+addOutput :: MonadBuildTx m => C.TxOut C.CtxTx C.BabbageEra -> m ()
+addOutput txOut = addBtx (over (L.txOuts . L.reversed) ((:) txOut))

src/coin-selection/convex-coin-selection.cabal

@@ -66,6 +66,7 @@ test-suite convex-coin-selection-test
     Spec.hs
   other-modules:
     Scripts
+    Scripts.MatchingIndex
   build-depends:
     base >= 4.14.0,
     tasty,

src/coin-selection/lib/Convex/CoinSelection.hs

@@ -58,8 +58,8 @@ import           Control.Monad             (when)
 import           Control.Monad.Except      (MonadError (..))
 import           Control.Monad.Trans.Class (MonadTrans (..))
 import           Control.Tracer            (Tracer, natTracer, traceWith)
-import           Convex.BuildTx            (addCollateral, execBuildTx,
-                                            setMinAdaDeposit,
+import           Convex.BuildTx            (addCollateral, buildTxWith,
+                                            execBuildTx, setMinAdaDeposit,
                                             spendPublicKeyOutput)
 import qualified Convex.CardanoApi         as CC
 import           Convex.Class              (MonadBlockchain (..))
@@ -459,7 +459,7 @@ addOwnInput body (Utxos.removeUtxos (spentTxIns body) -> UtxoSet{_utxos})
   | not (Map.null _utxos) =
       -- Select ada-only outputs if possible
       let availableUTxOs = List.sortOn (length . view (L._TxOut . _2 . L._TxOutValue . to C.valueToList) . fst . snd) (Map.toList _utxos)
-      in pure (execBuildTx (spendPublicKeyOutput (fst $ head availableUTxOs)) body)
+      in pure $ buildTxWith (execBuildTx (spendPublicKeyOutput (fst $ head availableUTxOs))) body
   | otherwise = throwError NoWalletUTxOs
 
 -- | Add a collateral input. Throws a 'NoAdaOnlyUTxOsForCollateral' error if a collateral input is required,
@@ -475,7 +475,7 @@ setCollateral body (Utxos.onlyAda -> UtxoSet{_utxos}) =
         -- select the output with the largest amount of Ada
         case listToMaybe $ List.sortOn (Down . C.selectLovelace . view (L._TxOut . _2 . L._TxOutValue) . fst . snd) $ Map.toList _utxos of
           Nothing     -> throwError NoAdaOnlyUTxOsForCollateral
-          Just (k, _) -> pure (execBuildTx (addCollateral k) body)
+          Just (k, _) -> pure $ buildTxWith (execBuildTx (addCollateral k)) body
 
 {-| Whether the transaction runs any plutus scripts
 -}