Revamping paysXXX with more flexible payments

CHANGELOG.md

@@ -28,11 +28,20 @@
   be used on a redeemer to manually attach a reference input (which does not
   necessarily have to contain the right reference script).
 - Capability to test the result of a mockchain run based on the log entries.
+- `txOutRefToTxSkelOut` helper to query the mock chain for recreating a
+  `TxSkelOut` from a `TxOutRef`. This is very useful when using Tweaks that need
+  to pay back an existing output with a slight modification.
+- A new tweak `modifySpendRedeemersOfTypeTweak` to apply an optional
+  modification of all redeemers of a certain type within the skeleton inputs.
+- Two new helpers `paysScriptNoValue` and `paysScriptOnlyAddress` to allow
+  payments to script with 0-ADA value, to be used alongside `txOptEnsureMinAda =
+  True` to avoid specifying an explicit amount of ADA.
 
 ### Removed
 
 - `positivePart` and `negativePart` in `ValueUtils.hs`. Replaced by `Api.split`.
 - Redundant logging of errors in mockchain runs.
+- Useless minting of non-ADA value in the dummy initial transaction.
 
 ### Changed
 
@@ -57,6 +66,8 @@
   * it is not visible from outside of `cooked-validators`
 - Dependency to cardano-api bumped to 8.46.
 - The whole testing API has been revamped
+- File `AddInputsAndOutputs.hs` has been split into `Inputs.hs`, `Outputs.hs`
+  and `Mint.hs`.
 
 ### Fixed
 
@@ -66,6 +77,8 @@
   in the excess.
 - Transactions that do not involve script are now properly generated without any
 - All kinds of scripts can now be used as reference scripts.
+- A bug where scripts being paid to in the initial distribution would not be
+  stored in the MockChain.
 
 ## [[4.0.0]](https://github.com/tweag/cooked-validators/releases/tag/v4.0.0) - 2024-06-28
 

cooked-validators.cabal

@@ -60,10 +60,12 @@ library
       Cooked.ShowBS
       Cooked.Skeleton
       Cooked.Tweak
-      Cooked.Tweak.AddInputsAndOutputs
       Cooked.Tweak.Common
+      Cooked.Tweak.Inputs
       Cooked.Tweak.Labels
+      Cooked.Tweak.Mint
       Cooked.Tweak.OutPermutations
+      Cooked.Tweak.Outputs
       Cooked.Tweak.Signers
       Cooked.Tweak.TamperDatum
       Cooked.Tweak.ValidityRange

flake.nix

@@ -41,6 +41,7 @@
             zlib
             xz
             glibcLocales
+            openssl_3_3
             postgresql # For pg_config
             ## We change the way 'blst' is built so that it takes into
             ## account the current architecture of the processor. This
@@ -65,6 +66,7 @@
               libsodium
               zlib
               xz
+              openssl_3_3
               postgresql # For cardano-node-emulator
               openldap # For freer-extras‽
             ];

src/Cooked/Conversion/ToCredential.hs

@@ -10,6 +10,10 @@ import PlutusLedgerApi.V3 qualified as Api
 class ToCredential a where
   toCredential :: a -> Api.Credential
 
+instance (ToCredential a, ToCredential b) => ToCredential (Either a b) where
+  toCredential (Left l) = toCredential l
+  toCredential (Right r) = toCredential r
+
 instance ToCredential Api.Credential where
   toCredential = id
 

src/Cooked/MockChain/BlockChain.hs

@@ -49,6 +49,7 @@ module Cooked.MockChain.BlockChain
     validateTxSkel_,
     txSkelProposalsDeposit,
     govActionDeposit,
+    txOutRefToTxSkelOut,
   )
 where
 
@@ -79,7 +80,7 @@ import Ledger.Index qualified as Ledger
 import Ledger.Slot qualified as Ledger
 import Ledger.Tx qualified as Ledger
 import Ledger.Tx.CardanoAPI qualified as Ledger
-import ListT
+import ListT hiding (null)
 import Optics.Core
 import Plutus.Script.Utils.Scripts qualified as Script
 import PlutusLedgerApi.V3 qualified as Api
@@ -381,6 +382,33 @@ txSkelInputDataAsHashes skel = do
   (Map.elems -> inputTxOuts) <- txSkelInputUtxos skel
   catMaybes <$> mapM outputToDatumHashM inputTxOuts
 
+-- | This creates a payment from an existing TxOut. This is not trivial because
+-- we need to reconstruct a bunch of information using data withing the blockchain
+txOutRefToTxSkelOut :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m TxSkelOut
+txOutRefToTxSkelOut oRef = do
+  Just txOut@(Api.TxOut (Api.Address cred _) _ dat refS) <- txOutByRef oRef
+  target <- case cred of
+    Api.PubKeyCredential pkh -> return $ Left pkh
+    Api.ScriptCredential (Api.ScriptHash sh) -> do
+      Just val <- validatorFromHash (Script.ValidatorHash sh)
+      return $ Right val
+  datum <- case dat of
+    Api.NoOutputDatum -> return TxSkelOutNoDatum
+    Api.OutputDatumHash hash -> do
+      Just (Api.Datum dat') <- datumFromHash hash
+      return $ TxSkelOutDatum dat' -- TODO: investigate between this and TxSkelOutDatum
+    Api.OutputDatum (Api.Datum dat') -> return $ TxSkelOutInlineDatum dat'
+  refScript <- case refS of
+    Nothing -> return Nothing
+    Just (Api.ScriptHash sh) -> validatorFromHash (Script.ValidatorHash sh)
+  return $
+    Pays $
+      (fromAbstractOutput txOut)
+        { concreteOutputOwner = target,
+          concreteOutputDatum = datum,
+          concreteOutputReferenceScript = refScript
+        }
+
 -- ** Slot and Time Management
 
 -- $slotandtime

src/Cooked/MockChain/MockChainSt.hs

@@ -15,7 +15,6 @@ import Cooked.Output
 import Cooked.Skeleton
 import Data.Bifunctor (bimap)
 import Data.Default
-import Data.Either.Combinators (mapLeft)
 import Data.List (foldl')
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
@@ -163,24 +162,38 @@ mockChainSt0 = MockChainSt def utxoIndex0 Map.empty Map.empty 0
 -- * Initial `MockChainSt` from an initial distribution
 
 mockChainSt0From :: InitialDistribution -> MockChainSt
-mockChainSt0From i0 = MockChainSt def (utxoIndex0From i0) (datumMap0From i0) (referenceScriptMap0From i0) 0
+mockChainSt0From i0 = MockChainSt def (utxoIndex0From i0) (datumMap0From i0) (referenceScriptMap0From i0 <> scriptMap0From i0) 0
 
 -- | Reference scripts from initial distributions should be accounted for in the
 -- `MockChainSt` which is done using this function.
 referenceScriptMap0From :: InitialDistribution -> Map Script.ValidatorHash (Script.Versioned Script.Validator)
-referenceScriptMap0From (InitialDistribution initDist) =
+referenceScriptMap0From =
   -- This builds a map of entries from the reference scripts contained in the
   -- initial distribution
-  Map.fromList $ mapMaybe unitMaybeFrom initDist
+  Map.fromList . mapMaybe unitMaybeFrom . unInitialDistribution
   where
     -- This takes a single output and returns a possible map entry when it
     -- contains a reference script
     unitMaybeFrom :: TxSkelOut -> Maybe (Script.ValidatorHash, Script.Versioned Script.Validator)
     unitMaybeFrom (Pays output) = do
       refScript <- view outputReferenceScriptL output
       let vScript@(Script.Versioned script version) = toVersionedScript refScript
-          Api.ScriptHash scriptHash = toScriptHash vScript
-      return (Script.ValidatorHash scriptHash, Script.Versioned (Script.Validator script) version)
+      return (Script.ValidatorHash $ Api.getScriptHash $ toScriptHash vScript, Script.Versioned (Script.Validator script) version)
+
+-- | Scripts from initial distributions should be accounted for in the
+-- `MockChainSt` which is done using this function.
+scriptMap0From :: InitialDistribution -> Map Script.ValidatorHash (Script.Versioned Script.Validator)
+scriptMap0From =
+  -- This builds a map of entries from the scripts contained in the initial
+  -- distribution
+  Map.fromList . mapMaybe unitMaybeFrom . unInitialDistribution
+  where
+    -- This takes a single output and returns a possible map entry when it
+    -- contains a script
+    unitMaybeFrom :: TxSkelOut -> Maybe (Script.ValidatorHash, Script.Versioned Script.Validator)
+    unitMaybeFrom txSkelOut = do
+      val <- txSkelOutValidator txSkelOut
+      return (Script.ValidatorHash $ Api.getScriptHash $ toScriptHash val, val)
 
 -- | Datums from initial distributions should be accounted for in the
 -- `MockChainSt` which is done using this function.
@@ -222,15 +235,13 @@ utxoIndex0From (InitialDistribution initDist) = case mkBody of
   where
     mkBody :: Either GenerateTxError (Cardano.TxBody Cardano.ConwayEra)
     mkBody = do
-      value <- mapLeft (ToCardanoError "Value error") $ Ledger.toCardanoValue (foldl' (\v -> (v <>) . view txSkelOutValueL) mempty initDist)
-      let mintValue = flip (Cardano.TxMintValue Cardano.MaryEraOnwardsConway) (Cardano.BuildTxWith mempty) . Cardano.filterValue (/= Cardano.AdaAssetId) $ value
-          theNetworkId = Cardano.Testnet $ Cardano.NetworkMagic 42
+      let theNetworkId = Cardano.Testnet $ Cardano.NetworkMagic 42
           genesisKeyHash = Cardano.GenesisUTxOKeyHash $ Shelley.KeyHash "23d51e91ae5adc7ae801e9de4cd54175fb7464ec2680b25686bbb194"
           inputs = [(Cardano.genesisUTxOPseudoTxIn theNetworkId genesisKeyHash, Cardano.BuildTxWith $ Cardano.KeyWitness Cardano.KeyWitnessForSpending)]
       outputs <- mapM (generateTxOut theNetworkId) initDist
       left (TxBodyError "Body error") $
         Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway $
-          Ledger.emptyTxBodyContent {Cardano.txMintValue = mintValue, Cardano.txOuts = outputs, Cardano.txIns = inputs}
+          Ledger.emptyTxBodyContent {Cardano.txOuts = outputs, Cardano.txIns = inputs}
 
 utxoIndex0 :: Ledger.UtxoIndex
 utxoIndex0 = utxoIndex0From def

src/Cooked/Skeleton.hs

@@ -59,6 +59,7 @@ module Cooked.Skeleton
     withStakingCredential,
     TxSkelRedeemer (..),
     Redeemer (..),
+    RedeemerConstrs,
     withReferenceInput,
     TxParameterChange (..),
     TxGovAction (..),
@@ -98,6 +99,9 @@ module Cooked.Skeleton
     txSkelReferenceTxOutRefs,
     someTxSkelRedeemer,
     emptyTxSkelRedeemer,
+    toTypedRedeemer,
+    paysScriptNoValue,
+    paysScriptOnlyAddress,
   )
 where
 
@@ -122,6 +126,7 @@ import Data.Map.NonEmpty qualified as NEMap
 import Data.Maybe
 import Data.Set (Set)
 import Data.Set qualified as Set
+import Data.Typeable (cast)
 import Ledger.Slot qualified as Ledger
 import Optics.Core
 import Optics.TH
@@ -430,6 +435,11 @@ data TxSkelRedeemer = TxSkelRedeemer
   }
   deriving (Show, Eq)
 
+-- Attempts to case a redeemer to a certain type
+toTypedRedeemer :: (Typeable a) => Redeemer -> Maybe a
+toTypedRedeemer (SomeRedeemer red) = cast red
+toTypedRedeemer EmptyRedeemer = Nothing
+
 -- Two helpers to create skeleton redeemers
 someTxSkelRedeemer :: (RedeemerConstrs redeemer) => redeemer -> TxSkelRedeemer
 someTxSkelRedeemer a = TxSkelRedeemer (SomeRedeemer a) Nothing
@@ -762,6 +772,9 @@ instance IsTxSkelOutAllowedOwner Api.PubKeyHash where
 instance IsTxSkelOutAllowedOwner (Script.TypedValidator a) where
   toPKHOrValidator = Right . Script.tvValidator
 
+instance IsTxSkelOutAllowedOwner (Either Api.PubKeyHash (Script.Versioned Script.Validator)) where
+  toPKHOrValidator = id
+
 -- | Transaction outputs. The 'Pays' constructor is really general, and you'll
 -- probably want to use one of the smart constructors like 'paysScript' or
 -- 'paysPK' in most cases.
@@ -899,7 +912,7 @@ txSkelOutTypedDatum = Api.fromBuiltinData . Api.getDatum <=< txSkelOutUntypedDat
 
 -- ** Smart constructors for transaction outputs
 
--- | Pay a certain value to a public key.
+-- | Pays a certain value to a public key.
 paysPK :: (ToPubKeyHash a) => a -> Api.Value -> TxSkelOut
 paysPK pkh value =
   Pays
@@ -936,6 +949,51 @@ paysScript validator datum value =
         (Nothing @(Script.Versioned Script.Script))
     )
 
+-- | Pays a script with a certain datum and a 0-ADA value. To be used with the
+-- automated minimal ADA adjustment 'txOptEnsureMinAda = True'.
+paysScriptNoValue ::
+  ( Api.ToData (Script.DatumType a),
+    Show (Script.DatumType a),
+    Typeable (Script.DatumType a),
+    PlutusTx.Eq (Script.DatumType a),
+    PrettyCooked (Script.DatumType a),
+    Typeable a
+  ) =>
+  Script.TypedValidator a ->
+  Script.DatumType a ->
+  TxSkelOut
+paysScriptNoValue validator datum =
+  Pays
+    ( ConcreteOutput
+        validator
+        Nothing
+        (TxSkelOutDatum datum)
+        (Script.ada 0)
+        (Nothing @(Script.Versioned Script.Script))
+    )
+
+-- | Pays a script with no datum and a 0-ADA value. To be used with the
+-- automated minimal ADA adjustment 'txOptEnsureMinAda = True'.
+paysScriptOnlyAddress ::
+  ( Api.ToData (Script.DatumType a),
+    Show (Script.DatumType a),
+    Typeable (Script.DatumType a),
+    PlutusTx.Eq (Script.DatumType a),
+    PrettyCooked (Script.DatumType a),
+    Typeable a
+  ) =>
+  Script.TypedValidator a ->
+  TxSkelOut
+paysScriptOnlyAddress validator =
+  Pays
+    ( ConcreteOutput
+        validator
+        Nothing
+        TxSkelOutNoDatum
+        (Script.ada 0)
+        (Nothing @(Script.Versioned Script.Script))
+    )
+
 -- | Pays a script a certain value with a certain inlined datum.
 paysScriptInlineDatum ::
   ( Api.ToData (Script.DatumType a),