Transaction generation now live in MonadBlockChainBalancing (#466)

* min ada in each output

* adding logging

* update CHANGELOG and CHEATSHEET

* some more comments

* AdjustableValue -> FixedValue

* begin to have generate tx live in our mockchain

* generateTx/xxx compiles

* all tests pass

* a few helpers adjustments

* preparing v5 release

Author: mmontin

CHANGELOG.md

@@ -4,6 +4,16 @@
 
 ### Added
 
+### Removed
+
+### Changed
+
+### Fixed
+
+## [[5.0.0]](https://github.com/tweag/cooked-validators/releases/tag/v5.0.0) - 2024-06-28
+
+### Added
+
 - `quickCurrencyPolicyV3` and `permanentCurrencyPolicyV3` which should be the
   most commonly used.
 - All kinds of scripts can now be used as reference scripts.
@@ -61,7 +71,6 @@
 - `txSkelInputData` changed to `txSkelInputDataAsHashes`
 - Pretty printing of hashed datum now includes the hash (and not only the
   resolved datum).
-- Dependency to cardano-api bumped to 8.46.
 - Logging has been reworked: 
   * it is no longer limited to `StagedMockChain` runs
   * it is now a component of `MonadBlockChainBalancing`
@@ -76,6 +85,8 @@
   `Output.hs`.
 - File `Skeleton.hs` has been split into sub-files in the `Skeleton` folder.
 - Default language extensions and compilation options have been updated.
+- Transaction generation now directly lives in `MonadMockChainBalancing`.
+- Initial distributions are now handled as a first action in the `MockChain`.
 
 ### Fixed
 

cooked-validators.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           cooked-validators
-version:        4.0.0
+version:        5.0.0
 license:        MIT
 license-file:   LICENSE
 build-type:     Simple

package.yaml

@@ -2,7 +2,7 @@ verbatim:
   cabal-version: 3.4
 
 name: cooked-validators
-version: 4.0.0
+version: 5.0.0
 
 dependencies:
   - QuickCheck

src/Cooked/MockChain/Balancing.hs

@@ -16,7 +16,7 @@ import Control.Monad
 import Control.Monad.Except
 import Cooked.Conversion
 import Cooked.MockChain.BlockChain
-import Cooked.MockChain.GenerateTx
+import Cooked.MockChain.GenerateTx.Body
 import Cooked.MockChain.MinAda
 import Cooked.MockChain.UtxoSearch
 import Cooked.Output
@@ -286,11 +286,11 @@ reachValue (h@(_, Api.txOutValue -> hVal) : t) target maxEls =
 -- `reachValue`. This throws an error when there are no suitable candidates.
 getOptimalCandidate :: (MonadBlockChainBalancing m) => [(BalancingOutputs, Api.Value)] -> Wallet -> MockChainError -> m ([Api.TxOutRef], Api.Value)
 getOptimalCandidate candidates paymentTarget mceError = do
-  params <- getParams
   -- We decorate the candidates with their current ada and min ada requirements
-  let candidatesDecorated = second (\val -> (val, Script.fromValue val, getTxSkelOutMinAda params $ paymentTarget `receives` Value val)) <$> candidates
-      -- We filter the candidates that have enough ada to sustain themselves
-      candidatesFiltered = [(minLv, (fst <$> l, val)) | (l, (val, Script.Lovelace lv, Right minLv)) <- candidatesDecorated, minLv <= lv]
+  candidatesDecorated <- forM candidates $ \(output, val) ->
+    (output,val,Script.fromValue val,) <$> getTxSkelOutMinAda (paymentTarget `receives` Value val)
+  -- We filter the candidates that have enough ada to sustain themselves
+  let candidatesFiltered = [(minLv, (fst <$> l, val)) | (l, val, Script.Lovelace lv, minLv) <- candidatesDecorated, minLv <= lv]
   case sortBy (compare `on` fst) candidatesFiltered of
     -- If the list of candidates is empty, we throw an error
     [] -> throwError mceError
@@ -302,20 +302,13 @@ estimateTxSkelFee :: (MonadBlockChainBalancing m) => TxSkel -> Fee -> Maybe (Col
 estimateTxSkelFee skel fee mCollaterals = do
   -- We retrieve the necessary data to generate the transaction body
   params <- getParams
-  managedData <- txSkelHashedData skel
   let collateralIns = case mCollaterals of
         Nothing -> []
         Just (s, _) -> Set.toList s
-  managedTxOuts <- lookupUtxos $ txSkelKnownTxOutRefs skel <> collateralIns
-  managedValidators <- txSkelInputValidators skel
   -- We generate the transaction body content, handling errors in the meantime
-  txBodyContent <- case generateBodyContent fee params managedData managedTxOuts managedValidators mCollaterals skel of
-    Left err -> throwError $ MCEGenerationError err
-    Right txBodyContent -> return txBodyContent
+  txBodyContent <- txSkelToTxBodyContent skel fee mCollaterals
   -- We create the actual body and send if for validation
-  txBody <- case Cardano.createAndValidateTransactionBody Cardano.ShelleyBasedEraConway txBodyContent of
-    Left err -> throwError $ MCEGenerationError $ TxBodyError "Error creating body when estimating fees" err
-    Right txBody -> return txBody
+  txBody <- txBodyContentToTxBody txBodyContent skel
   -- We retrieve the estimate number of required witness in the transaction
   let nkeys = Cardano.estimateTransactionKeyWitnessCount txBodyContent
   -- We need to reconstruct an index to pass to the fee estimate function
@@ -338,7 +331,6 @@ estimateTxSkelFee skel fee mCollaterals = do
 -- value + withdrawn value = output value + burned value + fee + deposits
 computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> TxSkel -> Fee -> m TxSkel
 computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (Script.lovelace -> feeValue) = do
-  params <- getParams
   -- We compute the necessary values from the skeleton that are part of the
   -- equation, except for the `feeValue` which we already have.
   let (burnedValue, mintedValue) = Api.split $ txSkelMintsValue txSkelMints
@@ -349,9 +341,7 @@ computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (Script.
   -- We compute the values missing in the left and right side of the equation
   let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue <> withdrawnValue)
   -- We compute the minimal ada requirement of the missing payment
-  rightMinAda <- case getTxSkelOutMinAda params $ balancingWallet `receives` Value missingRight of
-    Left err -> throwError $ MCEGenerationError err
-    Right a -> return a
+  rightMinAda <- getTxSkelOutMinAda $ balancingWallet `receives` Value missingRight
   -- We compute the current ada of the missing payment. If the missing payment
   -- is not empty and the minimal ada is not present, some value is missing.
   let Script.Lovelace rightAda = missingRight ^. Script.adaL

src/Cooked/MockChain/BlockChain.hs

@@ -14,7 +14,8 @@
 -- In addition, you will find here many helpers functions which can be derived
 -- from the core definition of our blockchain.
 module Cooked.MockChain.BlockChain
-  ( MockChainError (..),
+  ( GenerateTxError (..),
+    MockChainError (..),
     MockChainLogEntry (..),
     MonadBlockChainBalancing (..),
     MonadBlockChainWithoutValidation (..),
@@ -43,7 +44,6 @@ module Cooked.MockChain.BlockChain
     txSkelReferenceInputUtxos,
     txSkelInputValidators,
     txSkelInputValue,
-    txSkelHashedData,
     txSkelInputDataAsHashes,
     lookupUtxos,
     validateTxSkel',
@@ -55,6 +55,7 @@ module Cooked.MockChain.BlockChain
   )
 where
 
+import Cardano.Api qualified as Cardano
 import Cardano.Api.Ledger qualified as Cardano
 import Cardano.Ledger.Conway.PParams qualified as Conway
 import Cardano.Node.Emulator qualified as Emulator
@@ -69,7 +70,6 @@ import Control.Monad.Writer
 import Cooked.Conversion.ToCredential
 import Cooked.Conversion.ToOutputDatum
 import Cooked.Conversion.ToScriptHash
-import Cooked.MockChain.GenerateTx
 import Cooked.MockChain.UtxoState
 import Cooked.Output
 import Cooked.Skeleton
@@ -91,7 +91,17 @@ import PlutusLedgerApi.V3 qualified as Api
 
 -- * MockChain errors
 
--- | The errors that can be produced by the 'MockChainT' monad
+-- | Errors that can arise during transaction generation
+data GenerateTxError
+  = -- | Error when translating a skeleton element to its Cardano counterpart
+    ToCardanoError String Ledger.ToCardanoError
+  | -- | Error when generating a Cardano transaction body
+    TxBodyError String Cardano.TxBodyError
+  | -- | Other generation error
+    GenerateTxErrorGeneral String
+  deriving (Show, Eq)
+
+-- | Errors that can be produced by the 'MockChainT' monad
 data MockChainError
   = -- | Validation errors, either in Phase 1 or Phase 2
     MCEValidationError Ledger.ValidationPhase Ledger.ValidationError
@@ -288,10 +298,10 @@ resolveReferenceScript out | Just (Api.ScriptHash hash) <- outputReferenceScript
     return $ (fromAbstractOutput out) {concreteOutputReferenceScript = Just val}
 resolveReferenceScript _ = return Nothing
 
-outputDatumFromTxOutRef :: (MonadBlockChainWithoutValidation m) => Api.TxOutRef -> m (Maybe Api.OutputDatum)
+outputDatumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.OutputDatum)
 outputDatumFromTxOutRef = ((outputOutputDatum <$>) <$>) . txOutByRef
 
-datumFromTxOutRef :: (MonadBlockChainWithoutValidation m) => Api.TxOutRef -> m (Maybe Api.Datum)
+datumFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.Datum)
 datumFromTxOutRef oref = do
   mOutputDatum <- outputDatumFromTxOutRef oref
   case mOutputDatum of
@@ -300,10 +310,10 @@ datumFromTxOutRef oref = do
     Just (Api.OutputDatum datum) -> return $ Just datum
     Just (Api.OutputDatumHash datumHash) -> datumFromHash datumHash
 
-typedDatumFromTxOutRef :: (Api.FromData a, MonadBlockChainWithoutValidation m) => Api.TxOutRef -> m (Maybe a)
+typedDatumFromTxOutRef :: (Api.FromData a, MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe a)
 typedDatumFromTxOutRef = ((>>= (\(Api.Datum datum) -> Api.fromBuiltinData datum)) <$>) . datumFromTxOutRef
 
-valueFromTxOutRef :: (MonadBlockChainWithoutValidation m) => Api.TxOutRef -> m (Maybe Api.Value)
+valueFromTxOutRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.Value)
 valueFromTxOutRef = ((outputValue <$>) <$>) . txOutByRef
 
 txSkelInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Api.TxOut)
@@ -356,37 +366,16 @@ lookupUtxos =
 txSkelInputValue :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Value
 txSkelInputValue = (foldMap Api.txOutValue <$>) . txSkelInputUtxos
 
--- | Looks up and resolves the hashed datums on UTxOs the transaction consumes
--- or references, which will be needed by the transaction body.
-txSkelHashedData :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.DatumHash Api.Datum)
-txSkelHashedData skel = do
-  (Map.elems -> inputTxOuts) <- txSkelInputUtxos skel
-  (Map.elems -> refInputTxOuts) <- txSkelReferenceInputUtxos skel
-  foldM
-    ( \dat dHash ->
-        maybeErrM
-          (MCEUnknownDatum "txSkelHashedData: Transaction input with unknown datum hash" dHash)
-          (\rDat -> Map.insert dHash rDat dat)
-          (datumFromHash dHash)
-    )
-    Map.empty
-    (mapMaybe (fmap (^. outputDatumL) . isOutputWithDatumHash) $ inputTxOuts <> refInputTxOuts)
-
 -- | Looks up the data on UTxOs the transaction consumes and returns their
--- hashes. This corresponds to the keys of what should be removed from the
--- stored datums in our mockchain.  There can be duplicates, which is expected.
+-- hashes.
 txSkelInputDataAsHashes :: (MonadBlockChainBalancing m) => TxSkel -> m [Api.DatumHash]
 txSkelInputDataAsHashes skel = do
-  let outputToDatumHashM output = case output ^. outputDatumL of
-        Api.OutputDatumHash dHash ->
-          maybeErrM
-            (MCEUnknownDatum "txSkelInputDataAsHashes: Transaction input with unknown datum hash" dHash)
-            (Just . const dHash)
-            (datumFromHash dHash)
-        Api.OutputDatum datum -> return $ Just $ Script.datumHash datum
-        Api.NoOutputDatum -> return Nothing
+  let outputToDatumHash output = case output ^. outputDatumL of
+        Api.OutputDatumHash dHash -> Just dHash
+        Api.OutputDatum datum -> Just $ Script.datumHash datum
+        Api.NoOutputDatum -> Nothing
   (Map.elems -> inputTxOuts) <- txSkelInputUtxos skel
-  catMaybes <$> mapM outputToDatumHashM inputTxOuts
+  return $ mapMaybe outputToDatumHash inputTxOuts
 
 -- | This creates a payment from an existing UTXO
 txOutRefToTxSkelOut ::

src/Cooked/MockChain/Direct.hs

@@ -25,7 +25,6 @@ import Cooked.Output
 import Cooked.Skeleton
 import Data.Default
 import Data.Map.Strict qualified as Map
-import Data.Set qualified as Set
 import Ledger.Index qualified as Ledger
 import Ledger.Orphans ()
 import Ledger.Tx qualified as Ledger
@@ -82,13 +81,10 @@ mapMockChainT ::
   MockChainT n b
 mapMockChainT f = MockChainT . mapStateT (mapExceptT (mapWriterT f)) . unMockChain
 
--- | Executes a 'MockChainT' from some initial state; does /not/ convert the
--- 'MockChainSt' into a 'UtxoState'.
 runMockChainTRaw ::
-  MockChainSt ->
   MockChainT m a ->
   m (MockChainReturn a MockChainSt)
-runMockChainTRaw i0 = runWriterT . runExceptT . flip runStateT i0 . unMockChain
+runMockChainTRaw = runWriterT . runExceptT . flip runStateT def . unMockChain
 
 -- | Executes a 'MockChainT' from an initial state set up with the given initial
 -- value distribution. Similar to 'runMockChainT', uses the default
@@ -99,18 +95,15 @@ runMockChainTFrom ::
   InitialDistribution ->
   MockChainT m a ->
   m (MockChainReturn a UtxoState)
-runMockChainTFrom i0 s = first (right (second mcstToUtxoState)) <$> runMockChainTRaw (mockChainSt0From i0) s
+runMockChainTFrom i0 s =
+  first (right (second mcstToUtxoState))
+    <$> runMockChainTRaw (mockChainSt0From i0 >>= put >> s)
 
 -- | Executes a 'MockChainT' from the canonical initial state and environment.
--- The canonical environment uses the default 'SlotConfig' and
--- @Cooked.Wallet.wallet 1@ as the sole wallet signing transactions.
+-- The canonical environment uses the default 'SlotConfig'
 runMockChainT :: (Monad m) => MockChainT m a -> m (MockChainReturn a UtxoState)
 runMockChainT = runMockChainTFrom def
 
--- | See 'runMockChainTRaw'
-runMockChainRaw :: MockChain a -> MockChainReturn a MockChainSt
-runMockChainRaw = runIdentity . runMockChainTRaw def
-
 -- | See 'runMockChainTFrom'
 runMockChainFrom :: InitialDistribution -> MockChain a -> MockChainReturn a UtxoState
 runMockChainFrom i0 = runIdentity . runMockChainTFrom i0
@@ -156,22 +149,9 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where
     (skel, fee, mCollaterals) <- balanceTxSkel minAdaRefScriptsSkelUnbal
     -- We log the adjusted skeleton
     gets mcstToSkelContext >>= \ctx -> logEvent $ MCLogAdjustedTxSkel ctx skel fee mCollaterals
-    -- We retrieve data that will be used in the transaction generation process:
-    -- datums, validators and various kinds of inputs. This idea is to provide a
-    -- rich-enough context for the transaction generation to succeed.
-    hashedData <- txSkelHashedData skel
-    insData <- txSkelInputDataAsHashes skel
-    insValidators <- txSkelInputValidators skel
-    insMap <- txSkelInputUtxos skel
-    refInsMap <- txSkelReferenceInputUtxos skel
-    collateralInsMap <- maybe (return Map.empty) (lookupUtxos . Set.toList . fst) mCollaterals
-    -- We attempt to generate the transaction associated with the balanced
-    -- skeleton and the retrieved data. This is an internal generation, there is
-    -- no validation involved yet.
-    cardanoTx <- case generateTx fee newParams hashedData (insMap <> refInsMap <> collateralInsMap) insValidators mCollaterals skel of
-      Left err -> throwError . MCEGenerationError $ err
-      -- We apply post-generation modification when applicable
-      Right tx -> return $ Ledger.CardanoEmulatorEraTx $ applyRawModOnBalancedTx txOptUnsafeModTx tx
+    -- We generate the transaction associated with the skeleton, and apply on it
+    -- the modifications from the skeleton options
+    cardanoTx <- Ledger.CardanoEmulatorEraTx . applyRawModOnBalancedTx txOptUnsafeModTx <$> txSkelToCardanoTx skel fee mCollaterals
     -- To run transaction validation we need a minimal ledger state
     eLedgerState <- gets mcstToEmulatedLedgerState
     -- We finally run the emulated validation, and we only care about the
@@ -191,19 +171,20 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where
           -- In case of success, we update the index with all inputs and outputs
           -- contained in the transaction
           Ledger.Success {} -> (Ledger.insert cardanoTx utxoIndex, Nothing)
-    -- Now that we have compute a new index, we can update it
-    modify' (\st -> st {mcstIndex = newUtxoIndex})
     case valError of
       -- When validation failed for any reason, we throw an error. TODO: This
       -- behavior could be subject to change in the future.
       Just err -> throwError (uncurry MCEValidationError err)
       -- Otherwise, we update known validators and datums.
-      Nothing ->
+      Nothing -> do
+        insData <- txSkelInputDataAsHashes skel
         modify'
           ( removeDatums insData
               . addDatums (txSkelDataInOutputs skel)
               . addValidators (txSkelValidatorsInOutputs skel <> txSkelReferenceScripts skel)
           )
+    -- Now that we have computed a new index, we can update it
+    modify' (\st -> st {mcstIndex = newUtxoIndex})
     -- We apply a change of slot when requested in the options
     when txOptAutoSlotIncrease $ modify' (\st -> st {mcstCurrentSlot = mcstCurrentSlot st + 1})
     -- We return the parameters to their original state