Removing the dependency to Ledger.TxOut (#442)

* tests pass with new mockchain return type

* more log levels

* logging removal of unusable balancing utxos

* improving logging in balancing

* new log version with dedicated constructors

* changing item

* integrating comments, adding comments and more readable bullets

* fixing the bug where collateral inputs were not resolved

* CHANGELOG.md

* integrating review comments

* typo

* removing useless instances

* wip

* reverting balancingspec

* starting to consume scripts in balancing spec, to be continued

* reworking empty collaterals

* 2 first test groups passé

* all tests fixed

* doc

* updating doc

* logging of unused collateral option

* post-rebase small fixes

* bye bye Ledger.TxOut

* post merge mini fix

* post-merge fixes

* Typo

---------

Co-authored-by: mmontin <[email protected]>

src/Cooked/MockChain/Balancing.hs

@@ -30,7 +30,6 @@ import Data.Maybe
 import Data.Ratio qualified as Rat
 import Data.Set (Set)
 import Data.Set qualified as Set
-import Ledger.Tx qualified as Ledger
 import Ledger.Tx.CardanoAPI qualified as Ledger
 import Optics.Core
 import Plutus.Script.Utils.Ada qualified as Script
@@ -303,7 +302,7 @@ estimateTxSkelFee skel fee mCollaterals = do
   let collateralIns = case mCollaterals of
         Nothing -> []
         Just (s, _) -> Set.toList s
-  managedTxOuts <- lookupUtxosPl $ txSkelKnownTxOutRefs skel <> collateralIns
+  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
@@ -316,10 +315,17 @@ estimateTxSkelFee skel fee mCollaterals = do
   -- 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
+  -- We begin by retrieving the relevant utxos used in the skeleton
   (knownTxORefs, knownTxOuts) <- unzip . Map.toList <$> lookupUtxos (txSkelKnownTxOutRefs skel <> collateralIns)
-  index <- case forM knownTxORefs Ledger.toCardanoTxIn of
-    Left err -> throwError $ MCEGenerationError $ ToCardanoError "estimateTxSkelFee: unable to generate TxIn" err
-    Right txInL -> return $ Cardano.UTxO $ Map.fromList $ zip txInL $ Cardano.toCtxUTxOTxOut . Ledger.getTxOut <$> knownTxOuts
+  -- We then compute their Cardano counterparts
+  let indexOrError = do
+        txInL <- forM knownTxORefs Ledger.toCardanoTxIn
+        txOutL <- forM knownTxOuts $ Ledger.toCardanoTxOut $ Emulator.pNetworkId params
+        return $ Cardano.UTxO $ Map.fromList $ zip txInL $ Cardano.toCtxUTxOTxOut <$> txOutL
+  -- We retrieve the index when it was successfully created
+  index <- case indexOrError of
+    Left err -> throwError $ MCEGenerationError $ ToCardanoError "estimateTxSkelFee: toCardanoError" err
+    Right index' -> return index'
   -- We finally can the fee estimate function
   return . Emulator.unCoin $ Cardano.calculateMinTxFee Cardano.ShelleyBasedEraConway (Emulator.pEmulatorPParams params) index txBody nkeys
 

src/Cooked/MockChain/BlockChain.hs

@@ -20,13 +20,9 @@ module Cooked.MockChain.BlockChain
     MonadBlockChainWithoutValidation (..),
     MonadBlockChain (..),
     AsTrans (..),
-    allUtxos,
     currentTime,
     waitNSlots,
-    utxosAt,
-    txOutByRef,
     utxosFromCardanoTx,
-    txOutV2FromLedger,
     typedDatumFromTxOutRef,
     valueFromTxOutRef,
     outputDatumFromTxOutRef,
@@ -40,15 +36,12 @@ module Cooked.MockChain.BlockChain
     slotRangeBefore,
     slotRangeAfter,
     slotToTimeInterval,
-    txSkelInputUtxosPl,
     txSkelInputUtxos,
-    txSkelReferenceInputUtxosPl,
     txSkelReferenceInputUtxos,
     txSkelInputValidators,
     txSkelInputValue,
     txSkelInputData,
     lookupUtxos,
-    lookupUtxosPl,
     validateTxSkel',
     txSkelProposalsDeposit,
     govActionDeposit,
@@ -59,7 +52,6 @@ import Cardano.Api.Ledger qualified as Cardano
 import Cardano.Ledger.Conway.PParams qualified as Conway
 import Cardano.Node.Emulator qualified as Emulator
 import Cardano.Node.Emulator.Internal.Node qualified as Emulator
-import Control.Arrow
 import Control.Lens qualified as Lens
 import Control.Monad
 import Control.Monad.Except
@@ -140,7 +132,7 @@ class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m w
   getParams :: m Emulator.Params
 
   -- | Returns a list of all UTxOs at a certain address.
-  utxosAtLedger :: Api.Address -> m [(Api.TxOutRef, Ledger.TxOut)]
+  utxosAt :: Api.Address -> m [(Api.TxOutRef, Api.TxOut)]
 
   -- | Returns the datum with the given hash if present.
   datumFromHash :: Api.DatumHash -> m (Maybe Api.Datum)
@@ -150,14 +142,14 @@ class (MonadFail m, MonadError MockChainError m) => MonadBlockChainBalancing m w
   validatorFromHash :: Script.ValidatorHash -> m (Maybe (Script.Versioned Script.Validator))
 
   -- | Returns an output given a reference to it
-  txOutByRefLedger :: Api.TxOutRef -> m (Maybe Ledger.TxOut)
+  txOutByRef :: Api.TxOutRef -> m (Maybe Api.TxOut)
 
   -- | Logs an event that occured during a BlockChain run
   logEvent :: MockChainLogEntry -> m ()
 
 class (MonadBlockChainBalancing m) => MonadBlockChainWithoutValidation m where
   -- | Returns a list of all currently known outputs.
-  allUtxosLedger :: m [(Api.TxOutRef, Ledger.TxOut)]
+  allUtxos :: m [(Api.TxOutRef, Api.TxOut)]
 
   -- | Updates parameters
   setParams :: Emulator.Params -> m ()
@@ -190,26 +182,20 @@ class (MonadBlockChainWithoutValidation m) => MonadBlockChain m where
 validateTxSkel' :: (MonadBlockChain m) => TxSkel -> m [Api.TxOutRef]
 validateTxSkel' = (map fst . utxosFromCardanoTx <$>) . validateTxSkel
 
-allUtxos :: (MonadBlockChainWithoutValidation m) => m [(Api.TxOutRef, Api.TxOut)]
-allUtxos = fmap (second txOutV2FromLedger) <$> allUtxosLedger
-
-utxosAt :: (MonadBlockChainBalancing m) => Api.Address -> m [(Api.TxOutRef, Api.TxOut)]
-utxosAt address = fmap (second txOutV2FromLedger) <$> utxosAtLedger address
-
-txOutByRef :: (MonadBlockChainBalancing m) => Api.TxOutRef -> m (Maybe Api.TxOut)
-txOutByRef oref = fmap txOutV2FromLedger <$> txOutByRefLedger oref
-
 -- | Retrieve the ordered list of outputs of the given "CardanoTx".
 --
 -- This is useful when writing endpoints and/or traces to fetch utxos of
 -- interest right from the start and avoid querying the chain for them
 -- afterwards using 'allUtxos' or similar functions.
 utxosFromCardanoTx :: Ledger.CardanoTx -> [(Api.TxOutRef, Api.TxOut)]
 utxosFromCardanoTx =
-  map (\(txOut, txOutRef) -> (Ledger.fromCardanoTxIn txOutRef, txOutV2FromLedger txOut)) . Ledger.getCardanoTxOutRefs
-
-txOutV2FromLedger :: Ledger.TxOut -> Api.TxOut
-txOutV2FromLedger = Ledger.fromCardanoTxOutToPV2TxInfoTxOut . Ledger.getTxOut
+  map
+    ( \(txOut, txOutRef) ->
+        ( Ledger.fromCardanoTxIn txOutRef,
+          Ledger.fromCardanoTxOutToPV2TxInfoTxOut $ Ledger.getTxOut txOut
+        )
+    )
+    . Ledger.getCardanoTxOutRefs
 
 -- | Try to resolve the datum on the output: If there's an inline datum, take
 -- that; if there's a datum hash, look the corresponding datum up (with
@@ -335,16 +321,10 @@ typedDatumFromTxOutRef = ((>>= (\(Api.Datum datum) -> Api.fromBuiltinData datum)
 valueFromTxOutRef :: (MonadBlockChainWithoutValidation m) => Api.TxOutRef -> m (Maybe Api.Value)
 valueFromTxOutRef = ((outputValue <$>) <$>) . txOutByRef
 
-txSkelInputUtxosPl :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Api.TxOut)
-txSkelInputUtxosPl = lookupUtxosPl . Map.keys . txSkelIns
-
-txSkelInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Ledger.TxOut)
+txSkelInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Api.TxOut)
 txSkelInputUtxos = lookupUtxos . Map.keys . txSkelIns
 
-txSkelReferenceInputUtxosPl :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Api.TxOut)
-txSkelReferenceInputUtxosPl = (Map.map txOutV2FromLedger <$>) . txSkelReferenceInputUtxos
-
-txSkelReferenceInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Ledger.TxOut)
+txSkelReferenceInputUtxos :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.TxOutRef Api.TxOut)
 txSkelReferenceInputUtxos = lookupUtxos . txSkelReferenceTxOutRefs
 
 -- | Retrieves the required deposit amount for issuing governance actions.
@@ -363,7 +343,7 @@ maybeErrM err f = (maybe (throwError err) (return . f) =<<)
 -- | All validators which protect transaction inputs
 txSkelInputValidators :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Script.ValidatorHash (Script.Versioned Script.Validator))
 txSkelInputValidators skel = do
-  utxos <- Map.toList <$> lookupUtxosPl (Map.keys . txSkelIns $ skel)
+  utxos <- Map.toList <$> lookupUtxos (Map.keys . txSkelIns $ skel)
   Map.fromList . catMaybes
     <$> mapM
       ( \(_oref, out) -> case outputAddress out of
@@ -382,17 +362,14 @@ txSkelInputValidators skel = do
 
 -- | Go through all of the 'Api.TxOutRef's in the list and look them up in the
 -- state of the blockchain, throwing an error if one of them cannot be resolved.
-lookupUtxosPl :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> m (Map Api.TxOutRef Api.TxOut)
-lookupUtxosPl outRefs = Map.map txOutV2FromLedger <$> lookupUtxos outRefs
-
-lookupUtxos :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> m (Map Api.TxOutRef Ledger.TxOut)
+lookupUtxos :: (MonadBlockChainBalancing m) => [Api.TxOutRef] -> m (Map Api.TxOutRef Api.TxOut)
 lookupUtxos =
   (Map.fromList <$>)
-    . mapM (\oRef -> (oRef,) <$> maybeErrM (MCEUnknownOutRefError "lookupUtxos: unknown TxOutRef" oRef) id (txOutByRefLedger oRef))
+    . mapM (\oRef -> (oRef,) <$> maybeErrM (MCEUnknownOutRefError "lookupUtxos: unknown TxOutRef" oRef) id (txOutByRef oRef))
 
 -- | look up the UTxOs the transaction consumes, and sum their values.
 txSkelInputValue :: (MonadBlockChainBalancing m) => TxSkel -> m Api.Value
-txSkelInputValue = (foldMap (Api.txOutValue . txOutV2FromLedger) <$>) . txSkelInputUtxos
+txSkelInputValue = (foldMap Api.txOutValue <$>) . txSkelInputUtxos
 
 -- | Look up the data on UTxOs the transaction consumes.
 txSkelInputData :: (MonadBlockChainBalancing m) => TxSkel -> m (Map Api.DatumHash Api.Datum)
@@ -406,7 +383,7 @@ txSkelInputData skel = do
             Api.OutputDatumHash dHash -> Just dHash
       )
       . Map.elems
-      <$> txSkelInputUtxosPl skel
+      <$> txSkelInputUtxos skel
   Map.fromList
     <$> mapM
       ( \dHash ->
@@ -517,13 +494,13 @@ instance (MonadTransControl t, MonadError MockChainError m, Monad (t m)) => Mona
 instance (MonadTrans t, MonadBlockChainBalancing m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainBalancing (AsTrans t m) where
   getParams = lift getParams
   validatorFromHash = lift . validatorFromHash
-  utxosAtLedger = lift . utxosAtLedger
-  txOutByRefLedger = lift . txOutByRefLedger
+  utxosAt = lift . utxosAt
+  txOutByRef = lift . txOutByRef
   datumFromHash = lift . datumFromHash
   logEvent = lift . logEvent
 
 instance (MonadTrans t, MonadBlockChainWithoutValidation m, Monad (t m), MonadError MockChainError (AsTrans t m)) => MonadBlockChainWithoutValidation (AsTrans t m) where
-  allUtxosLedger = lift allUtxosLedger
+  allUtxos = lift allUtxos
   setParams = lift . setParams
   currentSlot = lift currentSlot
   awaitSlot = lift . awaitSlot
@@ -561,13 +538,13 @@ deriving via (AsTrans (StateT s) m) instance (MonadBlockChain m) => MonadBlockCh
 instance (MonadBlockChainBalancing m) => MonadBlockChainBalancing (ListT m) where
   getParams = lift getParams
   validatorFromHash = lift . validatorFromHash
-  utxosAtLedger = lift . utxosAtLedger
-  txOutByRefLedger = lift . txOutByRefLedger
+  utxosAt = lift . utxosAt
+  txOutByRef = lift . txOutByRef
   datumFromHash = lift . datumFromHash
   logEvent = lift . logEvent
 
 instance (MonadBlockChainWithoutValidation m) => MonadBlockChainWithoutValidation (ListT m) where
-  allUtxosLedger = lift allUtxosLedger
+  allUtxos = lift allUtxos
   setParams = lift . setParams
   currentSlot = lift currentSlot
   awaitSlot = lift . awaitSlot

src/Cooked/MockChain/Direct.hs

@@ -101,7 +101,7 @@ data MockChainSt = MockChainSt
 mcstToSkelContext :: MockChainSt -> SkelContext
 mcstToSkelContext MockChainSt {..} =
   SkelContext
-    (txOutV2FromLedger <$> getIndex mcstIndex)
+    (getIndex mcstIndex)
     (Map.map fst mcstDatums)
 
 -- | Generating an emulated state for the emulator from a mockchain state and
@@ -302,10 +302,10 @@ utxoIndex0 = utxoIndex0From def
 
 -- * Direct Interpretation of Operations
 
-getIndex :: Ledger.UtxoIndex -> Map Api.TxOutRef Ledger.TxOut
+getIndex :: Ledger.UtxoIndex -> Map Api.TxOutRef Api.TxOut
 getIndex =
   Map.fromList
-    . map (bimap Ledger.fromCardanoTxIn (Ledger.TxOut . toCtxTxTxOut))
+    . map (bimap Ledger.fromCardanoTxIn (Ledger.fromCardanoTxOutToPV2TxInfoTxOut . toCtxTxTxOut))
     . Map.toList
     . Cardano.unUTxO
   where
@@ -322,13 +322,13 @@ getIndex =
 instance (Monad m) => MonadBlockChainBalancing (MockChainT m) where
   getParams = gets mcstParams
   validatorFromHash valHash = gets $ Map.lookup valHash . mcstValidators
-  txOutByRefLedger outref = gets $ Map.lookup outref . getIndex . mcstIndex
+  txOutByRef outref = gets $ Map.lookup outref . getIndex . mcstIndex
   datumFromHash datumHash = (txSkelOutUntypedDatum <=< Just . fst <=< Map.lookup datumHash) <$> gets mcstDatums
-  utxosAtLedger addr = filter ((addr ==) . outputAddress . txOutV2FromLedger . snd) <$> allUtxosLedger
+  utxosAt addr = filter ((addr ==) . outputAddress . snd) <$> allUtxos
   logEvent l = tell [l]
 
 instance (Monad m) => MonadBlockChainWithoutValidation (MockChainT m) where
-  allUtxosLedger = gets $ Map.toList . getIndex . mcstIndex
+  allUtxos = gets $ Map.toList . getIndex . mcstIndex
   setParams newParams = modify (\st -> st {mcstParams = newParams})
   currentSlot = gets mcstCurrentSlot
   awaitSlot s = modify' (\st -> st {mcstCurrentSlot = max s (mcstCurrentSlot st)}) >> currentSlot
@@ -356,11 +356,11 @@ instance (Monad m) => MonadBlockChain (MockChainT m) where
     -- rich-enough context for the transaction generation to succeed.
     insData <- txSkelInputData skel
     insValidators <- txSkelInputValidators skel
-    insMap <- txSkelInputUtxosPl skel
-    refInsMap <- txSkelReferenceInputUtxosPl skel
+    insMap <- txSkelInputUtxos skel
+    refInsMap <- txSkelReferenceInputUtxos skel
     collateralInsMap <- case mCollaterals of
       Nothing -> return Map.empty
-      Just (collateralIns, _) -> lookupUtxosPl $ Set.toList collateralIns
+      Just (collateralIns, _) -> lookupUtxos $ Set.toList collateralIns
     -- 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.

src/Cooked/MockChain/Staged.hs

@@ -72,12 +72,12 @@ data MockChainBuiltin a where
   GetParams :: MockChainBuiltin Emulator.Params
   SetParams :: Emulator.Params -> MockChainBuiltin ()
   ValidateTxSkel :: TxSkel -> MockChainBuiltin Ledger.CardanoTx
-  TxOutByRefLedger :: Api.TxOutRef -> MockChainBuiltin (Maybe Ledger.TxOut)
+  TxOutByRef :: Api.TxOutRef -> MockChainBuiltin (Maybe Api.TxOut)
   GetCurrentSlot :: MockChainBuiltin Ledger.Slot
   AwaitSlot :: Ledger.Slot -> MockChainBuiltin Ledger.Slot
   DatumFromHash :: Api.DatumHash -> MockChainBuiltin (Maybe Api.Datum)
-  AllUtxosLedger :: MockChainBuiltin [(Api.TxOutRef, Ledger.TxOut)]
-  UtxosAtLedger :: Api.Address -> MockChainBuiltin [(Api.TxOutRef, Ledger.TxOut)]
+  AllUtxos :: MockChainBuiltin [(Api.TxOutRef, Api.TxOut)]
+  UtxosAt :: Api.Address -> MockChainBuiltin [(Api.TxOutRef, Api.TxOut)]
   ValidatorFromHash :: Script.ValidatorHash -> MockChainBuiltin (Maybe (Script.Versioned Script.Validator))
   LogEvent :: MockChainLogEntry -> MockChainBuiltin ()
   -- | The empty set of traces
@@ -124,13 +124,13 @@ instance InterpLtl (UntypedTweak InterpMockChain) MockChainBuiltin InterpMockCha
         (_, skel') <- lift $ runTweakInChain now skel
         put later
         validateTxSkel skel'
-  interpBuiltin (TxOutByRefLedger o) = txOutByRefLedger o
+  interpBuiltin (TxOutByRef o) = txOutByRef o
   interpBuiltin GetCurrentSlot = currentSlot
   interpBuiltin (AwaitSlot s) = awaitSlot s
   interpBuiltin (DatumFromHash h) = datumFromHash h
   interpBuiltin (ValidatorFromHash h) = validatorFromHash h
-  interpBuiltin AllUtxosLedger = allUtxosLedger
-  interpBuiltin (UtxosAtLedger address) = utxosAtLedger address
+  interpBuiltin AllUtxos = allUtxos
+  interpBuiltin (UtxosAt address) = utxosAt address
   interpBuiltin Empty = mzero
   interpBuiltin (Alt l r) = interpLtl l `mplus` interpLtl r
   interpBuiltin (Fail msg) = fail msg
@@ -198,13 +198,13 @@ instance MonadError MockChainError StagedMockChain where
 instance MonadBlockChainBalancing StagedMockChain where
   getParams = singletonBuiltin GetParams
   datumFromHash = singletonBuiltin . DatumFromHash
-  txOutByRefLedger = singletonBuiltin . TxOutByRefLedger
-  utxosAtLedger = singletonBuiltin . UtxosAtLedger
+  txOutByRef = singletonBuiltin . TxOutByRef
+  utxosAt = singletonBuiltin . UtxosAt
   validatorFromHash = singletonBuiltin . ValidatorFromHash
   logEvent = singletonBuiltin . LogEvent
 
 instance MonadBlockChainWithoutValidation StagedMockChain where
-  allUtxosLedger = singletonBuiltin AllUtxosLedger
+  allUtxos = singletonBuiltin AllUtxos
   setParams = singletonBuiltin . SetParams
   currentSlot = singletonBuiltin GetCurrentSlot
   awaitSlot = singletonBuiltin . AwaitSlot

src/Cooked/MockChain/UtxoSearch.hs

@@ -5,9 +5,7 @@ module Cooked.MockChain.UtxoSearch
   ( UtxoSearch,
     runUtxoSearch,
     allUtxosSearch,
-    allUtxosLedgerSearch,
     utxosAtSearch,
-    utxosAtLedgerSearch,
     utxosFromCardanoTxSearch,
     txOutByRefSearch,
     filterWith,
@@ -54,21 +52,11 @@ runUtxoSearch = ListT.toList
 allUtxosSearch :: (MonadBlockChain m) => UtxoSearch m Api.TxOut
 allUtxosSearch = allUtxos >>= ListT.fromFoldable
 
--- | Like 'allUtxosSearch', but returns a Ledger-level representation of the
--- transaction outputs, which might contain more information.
-allUtxosLedgerSearch :: (MonadBlockChain m) => UtxoSearch m Ledger.TxOut
-allUtxosLedgerSearch = allUtxosLedger >>= ListT.fromFoldable
-
 -- | Search all 'TxOutRef's at a certain address, together with their
 -- 'TxInfo'-'TxOut'.
 utxosAtSearch :: (MonadBlockChainBalancing m, ToAddress addr) => addr -> UtxoSearch m Api.TxOut
 utxosAtSearch = utxosAt . toAddress >=> ListT.fromFoldable
 
--- | Like 'utxosAtSearch', but returns a Ledger-level representation of the
--- transaction outputs, which might contain more information.
-utxosAtLedgerSearch :: (MonadBlockChainBalancing m, ToAddress addr) => addr -> UtxoSearch m Ledger.TxOut
-utxosAtLedgerSearch = utxosAtLedger . toAddress >=> ListT.fromFoldable
-
 -- | Search all 'TxOutRef's of a transaction, together with their
 -- 'TxInfo'-'TxOut'.
 utxosFromCardanoTxSearch :: (Monad m) => Ledger.CardanoTx -> UtxoSearch m Api.TxOut

src/Cooked/Skeleton.hs

@@ -1100,7 +1100,7 @@ txSkelReferenceTxOutRefs TxSkel {..} =
   Set.toList txSkelInsReference
     -- reference inputs in inputs redeemers
     <> mapMaybe txSkelReferenceScript (Map.elems txSkelIns)
-    -- reference inputs in porposals redeemers
+    -- reference inputs in proposals redeemers
     <> mapMaybe (txSkelReferenceScript . snd) (mapMaybe txSkelProposalWitness txSkelProposals)
     -- reference inputs in mints redeemers
     <> mapMaybe (txSkelReferenceScript . fst . snd) (Map.toList txSkelMints)