Fix cardano-node-emulator

Author: sjoerdvisscher

cardano-node-emulator/cardano-node-emulator.cabal

@@ -45,28 +45,30 @@ library
   -- Local components
   --------------------
   build-depends:
-    , freer-extras   >=1.2.0
-    , plutus-ledger  >=1.2.0
+    , freer-extras         >=1.2.0
+    , plutus-ledger        >=1.2.0
+    , plutus-script-utils  >=1.2.0
 
   --------------------------
   -- Other IOG dependencies
   --------------------------
   build-depends:
-    , cardano-api:{cardano-api, gen}  >=8.0
+    , cardano-api:{cardano-api, gen}  ^>=8.2
     , cardano-crypto
     , cardano-ledger-allegra
     , cardano-ledger-alonzo
+    , cardano-ledger-api
     , cardano-ledger-babbage
     , cardano-ledger-core
     , cardano-ledger-mary
     , cardano-ledger-shelley
     , cardano-slotting
-    , mtl
     , ouroboros-consensus
     , plutus-core                     >=1.0.0
     , plutus-ledger-api               >=1.0.0
     , plutus-tx                       >=1.0.0
-    , quickcheck-contractmodel        >=0.1.4.0
+
+  -- , quickcheck-contractmodel        >=0.1.4.0
 
   ------------------------
   -- Non-IOG dependencies
@@ -86,6 +88,7 @@ library
     , mtl
     , prettyprinter              >=1.1.0.1
     , QuickCheck
+    , quickcheck-contractmodel
     , quickcheck-dynamic
     , serialise
     , text

cardano-node-emulator/src/Cardano/Node/Emulator/Generators.hs

@@ -79,7 +79,6 @@ import Data.Maybe (fromMaybe, isNothing)
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.String (fromString)
-import Gen.Cardano.Api.Typed qualified as Gen
 import GHC.Stack (HasCallStack)
 import Hedgehog (Gen, MonadGen, MonadTest, Range)
 import Hedgehog qualified as H
@@ -91,15 +90,16 @@ import Ledger (CardanoTx (CardanoEmulatorEraTx), Interval, MintingPolicy (getMin
                ValidationErrorInPhase, ValidationPhase (Phase1, Phase2), ValidationResult (FailPhase1, FailPhase2),
                addCardanoTxSignature, createGenesisTransaction, minLovelaceTxOutEstimated, pubKeyAddress, txOutValue)
 import Ledger.CardanoWallet qualified as CW
+import Ledger.Scripts qualified as Script
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.CardanoAPI (ToCardanoError, fromCardanoPlutusScript)
 import Ledger.Tx.CardanoAPI qualified as C hiding (makeTransactionBody)
 import Ledger.Value.CardanoAPI qualified as Value
 import Numeric.Natural (Natural)
-import Plutus.V1.Ledger.Api qualified as V1
-import Plutus.V1.Ledger.Interval qualified as Interval
-import Plutus.V1.Ledger.Scripts qualified as Script
+import PlutusLedgerApi.V1 qualified as V1
+import PlutusLedgerApi.V1.Interval qualified as Interval
 import PlutusTx (toData)
+import Test.Gen.Cardano.Api.Typed qualified as Gen
 
 -- | Attach signatures of all known private keys to a transaction.
 signAll :: CardanoTx -> CardanoTx
@@ -222,7 +222,7 @@ makeTx
     => C.TxBodyContent C.BuildTx C.BabbageEra
     -> m CardanoTx
 makeTx bodyContent = do
-    txBody <- either (fail . ("makeTx: Can't create TxBody: " <>) . show) pure $ C.makeTransactionBody bodyContent
+    txBody <- either (fail . ("makeTx: Can't create TxBody: " <>) . show) pure $ C.createAndValidateTransactionBody bodyContent
     pure $ signAll $ CardanoEmulatorEraTx $ C.Tx txBody []
 
 -- | Generate a valid transaction, using the unspent outputs provided.
@@ -278,7 +278,7 @@ genValidTransactionBodySpending' g ins totalVal = do
                                                   (C.AsPlutusScript C.AsPlutusScriptV2)
                                                   (getMintingPolicy alwaysSucceedPolicy))
                            <*> pure C.NoScriptDatumForMint
-                           <*> pure (C.fromPlutusData $ toData Script.unitRedeemer)
+                           <*> pure (C.unsafeHashableScriptData $ C.fromPlutusData $ toData Script.unitRedeemer)
                            <*> pure C.zeroExecutionUnits
     let txMintValue = C.TxMintValue C.MultiAssetInBabbageEra (fromMaybe mempty mintValue)
                           (C.BuildTxWith (Map.singleton alwaysSucceedPolicyId mintWitness))

cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Chain.hs

@@ -33,7 +33,7 @@ import GHC.Generics (Generic)
 import Ledger (Block, Blockchain, CardanoTx, OnChainTx, Slot (Slot), getCardanoTxId, getCardanoTxValidityRange,
                unOnChain)
 import Ledger.Index qualified as Index
-import Ledger.Interval qualified as Interval
+import PlutusLedgerApi.V1.Interval qualified as Interval
 import Prettyprinter (Pretty (pretty), vsep, (<+>))
 
 -- | Events produced by the blockchain emulator.

cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Fee.hs

@@ -19,10 +19,8 @@ module Cardano.Node.Emulator.Internal.Node.Fee(
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
 import Cardano.Api.Shelley qualified as C.Api
-import Cardano.Ledger.BaseTypes (Globals (systemStart))
-import Cardano.Ledger.Core qualified as C.Ledger (Tx)
-import Cardano.Ledger.Shelley.API qualified as C.Ledger hiding (Tx)
-import Cardano.Node.Emulator.Internal.Node.Params (EmulatorEra, PParams, Params (emulatorPParams), emulatorEraHistory,
+import Cardano.Ledger.BaseTypes (Globals (systemStart), epochInfo)
+import Cardano.Node.Emulator.Internal.Node.Params (EmulatorEra, Params (emulatorPParams), bundledProtocolParameters,
                                                    emulatorGlobals, pProtocolParams)
 import Cardano.Node.Emulator.Internal.Node.Validation (CardanoLedgerError, UTxO (UTxO), makeTransactionBody)
 import Control.Arrow ((&&&))
@@ -40,20 +38,19 @@ import Ledger.Index (UtxoIndex, ValidationError (MaxCollateralInputsExceeded, Tx
                      ValidationPhase (Phase1), adjustTxOut, minAdaTxOutEstimated)
 import Ledger.Tx (ToCardanoError (TxBodyError), TxOut)
 import Ledger.Tx qualified as Tx
-import Ledger.Tx.CardanoAPI (CardanoBuildTx (CardanoBuildTx), fromPlutusIndex, getCardanoBuildTx, toCardanoFee,
+import Ledger.Tx.CardanoAPI (CardanoBuildTx (CardanoBuildTx), getCardanoBuildTx, toCardanoFee,
                              toCardanoReturnCollateral, toCardanoTotalCollateral)
 import Ledger.Tx.CardanoAPI qualified as CardanoAPI
 import Ledger.Value.CardanoAPI (isZero, lovelaceToValue, split, valueGeq)
 
 estimateCardanoBuildTxFee
   :: Params
-  -> UTxO EmulatorEra
   -> CardanoBuildTx
   -> Either CardanoLedgerError C.Lovelace
-estimateCardanoBuildTxFee params utxo txBodyContent = do
+estimateCardanoBuildTxFee params txBodyContent = do
   let nkeys = C.Api.estimateTransactionKeyWitnessCount (getCardanoBuildTx txBodyContent)
-  txBody <- makeTransactionBody params utxo txBodyContent
-  pure $ evaluateTransactionFee (emulatorPParams params) txBody nkeys
+  txBody <- makeTransactionBody txBodyContent
+  pure $ evaluateTransactionFee (bundledProtocolParameters params) txBody nkeys
 
 -- | Creates a balanced transaction by calculating the execution units, the fees and the change,
 -- which is assigned to the given address. Only balances Ada.
@@ -65,7 +62,7 @@ makeAutoBalancedTransaction
   -> Either CardanoLedgerError (C.Api.Tx C.Api.BabbageEra)
 makeAutoBalancedTransaction params utxo (CardanoBuildTx txBodyContent) cChangeAddr = first Right $ do
   -- Compute the change.
-  C.Api.BalancedTxBody _ change _ <- first (TxBodyError . C.Api.displayError) $ balance []
+  C.Api.BalancedTxBody _ _ change _ <- first (TxBodyError . C.Api.displayError) $ balance []
   let
     -- Recompute execution units with full set of UTxOs, including change.
     trial = balance [change]
@@ -76,18 +73,19 @@ makeAutoBalancedTransaction params utxo (CardanoBuildTx txBodyContent) cChangeAd
           C.Api.TxOut addr (C.Api.TxOutValue vtype $ value <> lovelaceToValue delta) datum _referenceScript
         _ -> change
   -- Construct the body with correct execution units and fees.
-  C.Api.BalancedTxBody txBody _ _ <- first (TxBodyError . C.Api.displayError) $ balance [change']
+  C.Api.BalancedTxBody _ txBody _ _ <- first (TxBodyError . C.Api.displayError) $ balance [change']
   pure $ C.Api.makeSignedTransaction [] txBody
   where
-    eh = emulatorEraHistory params
-    ss = systemStart $ emulatorGlobals params
+    globals = emulatorGlobals params
+    ei = C.Api.LedgerEpochInfo $ epochInfo globals
+    ss = systemStart globals
     utxo' = fromLedgerUTxO utxo
     balance extraOuts = C.Api.makeTransactionBodyAutoBalance
-      C.Api.BabbageEraInCardanoMode
       ss
-      eh
+      ei
       (pProtocolParams params)
       mempty
+      mempty
       utxo'
       txBodyContent { C.Api.txOuts = C.Api.txOuts txBodyContent ++ extraOuts }
       cChangeAddr
@@ -117,11 +115,10 @@ makeAutoBalancedTransactionWithUtxoProvider params txUtxo cChangeAddr utxoProvid
 
         calcFee n fee = do
 
-            (txBodyContent, extraUtxos) <- handleBalanceTx params txUtxo cChangeAddr utxoProvider errorReporter fee unbalancedBodyContent
+            (txBodyContent, _) <- handleBalanceTx params txUtxo cChangeAddr utxoProvider errorReporter fee unbalancedBodyContent
 
             newFee <- either errorReporter pure $ do
-                let cUtxo = fromPlutusIndex $ txUtxo <> extraUtxos
-                estimateCardanoBuildTxFee params cUtxo (CardanoBuildTx txBodyContent)
+                estimateCardanoBuildTxFee params (CardanoBuildTx txBodyContent)
 
             if newFee /= fee
                 then if n == (0 :: Int)
@@ -132,11 +129,10 @@ makeAutoBalancedTransactionWithUtxoProvider params txUtxo cChangeAddr utxoProvid
 
     theFee <- calcFee 5 initialFeeEstimate
 
-    (txBodyContent, extraUtxos) <- handleBalanceTx params txUtxo cChangeAddr utxoProvider errorReporter theFee unbalancedBodyContent
+    (txBodyContent, _) <- handleBalanceTx params txUtxo cChangeAddr utxoProvider errorReporter theFee unbalancedBodyContent
 
     either errorReporter pure $ do
-        let cUtxo = fromPlutusIndex $ txUtxo <> extraUtxos
-        C.makeSignedTransaction [] <$> makeTransactionBody params cUtxo (CardanoBuildTx txBodyContent)
+        C.makeSignedTransaction [] <$> makeTransactionBody (CardanoBuildTx txBodyContent)
 
 -- | Balance an unbalanced transaction by adding missing inputs and outputs
 handleBalanceTx
@@ -351,9 +347,5 @@ fromLedgerUTxO (UTxO utxo) =
   $ utxo
 
 -- Adapted from cardano-api Cardano.API.Fee to avoid PParams conversion
-evaluateTransactionFee :: PParams -> C.Api.TxBody C.Api.BabbageEra -> Word -> C.Api.Lovelace
-evaluateTransactionFee pparams txbody keywitcount = case C.Api.makeSignedTransaction [] txbody of
-      C.Api.ShelleyTx _  tx -> evalShelleyBasedEra tx
-  where
-    evalShelleyBasedEra :: C.Ledger.Tx (C.Api.ShelleyLedgerEra C.Api.BabbageEra) -> C.Api.Lovelace
-    evalShelleyBasedEra tx = C.Api.fromShelleyLovelace $ C.Ledger.evaluateTransactionFee pparams tx keywitcount
+evaluateTransactionFee :: C.BundledProtocolParameters C.Api.BabbageEra -> C.Api.TxBody C.Api.BabbageEra -> Word -> C.Api.Lovelace
+evaluateTransactionFee params txbody keywitcount = C.evaluateTransactionFee params txbody keywitcount 0

cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/Params.hs

@@ -5,14 +5,16 @@
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TemplateHaskell    #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TupleSections      #-}
 -- | The set of parameters, like protocol parameters and slot configuration.
 module Cardano.Node.Emulator.Internal.Node.Params (
   Params(..),
   paramsWithProtocolsParameters,
   slotConfigL,
   emulatorPParamsL,
-  pParamsFromProtocolParams,
   pProtocolParams,
+  pParamsFromProtocolParams,
+  bundledProtocolParameters,
   protocolParamsL,
   networkIdL,
   increaseTransactionLimits,
@@ -30,10 +32,12 @@ module Cardano.Node.Emulator.Internal.Node.Params (
 
 import Cardano.Api qualified as C
 import Cardano.Api.Shelley qualified as C
+import Cardano.Ledger.Alonzo.PParams qualified as C
+import Cardano.Ledger.Alonzo.Scripts qualified as Alonzo
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.PParams (retractPP)
 import Cardano.Ledger.Babbage.PParams qualified as C
 import Cardano.Ledger.BaseTypes (boundRational)
+import Cardano.Ledger.Core qualified as C
 import Cardano.Ledger.Crypto (StandardCrypto)
 import Cardano.Ledger.Shelley.API (Coin (Coin), Globals, ShelleyGenesis, mkShelleyGlobals)
 import Cardano.Ledger.Shelley.API qualified as C.Ledger
@@ -47,17 +51,18 @@ import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Object), (.:),
 import Data.Aeson qualified as JSON
 import Data.Aeson.Types (prependFailure, typeMismatch)
 import Data.Default (Default (def))
-import Data.Map (fromList)
-import Data.Maybe (fromMaybe)
+import Data.Map qualified as Map
+import Data.Maybe (fromJust, fromMaybe)
 import Data.Ratio ((%))
+import Data.SOP.Counting qualified as Ouroboros
 import Data.SOP.Strict (K (K), NP (Nil, (:*)))
 import GHC.Generics (Generic)
 import GHC.Natural (Natural)
 import Ledger.Test (testnet)
 import Ouroboros.Consensus.HardFork.History qualified as Ouroboros
-import Ouroboros.Consensus.Util.Counting qualified as Ouroboros
-import Plutus.V1.Ledger.Api (POSIXTime (POSIXTime))
-import PlutusCore (defaultCostModelParams)
+import Plutus.Script.Utils.Scripts (Language (PlutusV3))
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCostModelParams)
+import PlutusLedgerApi.V1 (POSIXTime (POSIXTime))
 import Prettyprinter (Pretty (pretty), viaShow, vsep, (<+>))
 
 -- | The default era for the emulator
@@ -94,7 +99,13 @@ pProtocolParams :: Params -> C.ProtocolParameters
 pProtocolParams p = C.fromLedgerPParams C.ShelleyBasedEraBabbage $ emulatorPParams p
 
 pParamsFromProtocolParams :: C.ProtocolParameters -> PParams
-pParamsFromProtocolParams = C.toLedgerPParams C.ShelleyBasedEraBabbage
+pParamsFromProtocolParams = either (error . show) id . C.toLedgerPParams C.ShelleyBasedEraBabbage
+
+bundledProtocolParameters :: Params -> C.BundledProtocolParameters C.BabbageEra
+bundledProtocolParameters params = C.BundleAsShelleyBasedProtocolParameters
+  C.ShelleyBasedEraBabbage
+  (pProtocolParams params)
+  (emulatorPParams params)
 
 paramsWithProtocolsParameters :: SlotConfig -> C.ProtocolParameters -> C.NetworkId -> Params
 paramsWithProtocolsParameters sc p = Params sc (pParamsFromProtocolParams p)
@@ -114,7 +125,7 @@ instance ToJSON Params where
 instance FromJSON Params where
   parseJSON (Object v) = Params
     <$> (v .: "pSlotConfig" >>= parseJSON)
-    <*> (C.toLedgerPParams C.ShelleyBasedEraBabbage <$> (v .: "pProtocolParams" >>= parseJSON))
+    <*> (pParamsFromProtocolParams <$> (v .: "pProtocolParams" >>= parseJSON))
     <*> (v .: "pNetworkId" >>= parseJSON)
   parseJSON _ = fail "Can't parse a Param"
 
@@ -163,9 +174,10 @@ instance Default C.ProtocolParameters where
     , protocolParamMonetaryExpansion = 3 % 1000
     , protocolParamTreasuryCut = 1 % 5
     , protocolParamUTxOCostPerWord = Nothing -- Obsolete from babbage onwards
-    , protocolParamCostModels = fromList
-      [ (C.AnyPlutusScriptVersion C.PlutusScriptV1, C.CostModel $ fromMaybe (error "Ledger.Params: defaultCostModelParams is broken") defaultCostModelParams)
-      , (C.AnyPlutusScriptVersion C.PlutusScriptV2, C.CostModel $ fromMaybe (error "Ledger.Params: defaultCostModelParams is broken") defaultCostModelParams) ]
+    , protocolParamCostModels =
+        let costModel = fromJust $ defaultCostModelParams >>= Alonzo.costModelFromMap PlutusV3
+            costModels = Map.fromList $ map (, costModel) [minBound .. maxBound]
+        in C.fromAlonzoCostModels $ Alonzo.CostModels costModels mempty mempty
     , protocolParamPrices = Just (C.ExecutionUnitPrices {priceExecutionSteps = 721 % 10000000, priceExecutionMemory = 577 % 10000})
     , protocolParamMaxTxExUnits = Just (C.ExecutionUnits {executionSteps = 10000000000, executionMemory = 14000000})
     , protocolParamMaxBlockExUnits = Just (C.ExecutionUnits {executionSteps = 40000000000, executionMemory = 62000000})
@@ -192,14 +204,18 @@ emulatorGlobals :: Params -> Globals
 emulatorGlobals params = mkShelleyGlobals
   (genesisDefaultsFromParams params)
   (fixedEpochInfo emulatorEpochSize (slotLength params))
-  (fst $ C.protocolParamProtocolVersion $ pProtocolParams params)
+  (toEnum $ fromIntegral $ fst $ C.protocolParamProtocolVersion $ pProtocolParams params)
 
-genesisDefaultsFromParams :: Params -> ShelleyGenesis EmulatorEra
+genesisDefaultsFromParams :: Params -> ShelleyGenesis StandardCrypto
 genesisDefaultsFromParams params@Params { pSlotConfig, pNetworkId } = C.shelleyGenesisDefaults
   { C.sgSystemStart = posixTimeToUTCTime $ scSlotZeroTime pSlotConfig
   , C.sgNetworkMagic = case pNetworkId of C.Testnet (C.NetworkMagic nm) -> nm; _ -> 0
   , C.sgNetworkId = case pNetworkId of C.Testnet _ -> C.Ledger.Testnet; C.Mainnet -> C.Ledger.Mainnet
-  , C.sgProtocolParams = retractPP (Coin 0) d C.Ledger.NeutralNonce $ emulatorPParams params
+  , C.sgProtocolParams =  emulatorPParams params
+      & C.downgradePParams (C.DowngradeBabbagePParams d C.Ledger.NeutralNonce)
+      & C.downgradePParams (C.DowngradeAlonzoPParams (Coin 0))
+      & C.downgradePParams ()
+      & C.downgradePParams ()
   }
   where
     d = fromMaybe (error "3 % 5 should be valid UnitInterval") $ boundRational (3 % 5)
@@ -209,4 +225,4 @@ emulatorEraHistory :: Params -> C.EraHistory C.CardanoMode
 emulatorEraHistory params = C.EraHistory C.CardanoMode (Ouroboros.mkInterpreter $ Ouroboros.summaryWithExactly list)
   where
     one = Ouroboros.nonEmptyHead $ Ouroboros.getSummary $ Ouroboros.neverForksSummary emulatorEpochSize (slotLength params)
-    list = Ouroboros.Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* Nil
+    list = Ouroboros.Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* K one :* Nil

cardano-node-emulator/src/Cardano/Node/Emulator/Internal/Node/TimeSlot.hs

@@ -33,9 +33,9 @@ import Data.Time.Clock.POSIX qualified as Time
 import GHC.Generics (Generic)
 import Ledger.Orphans ()
 import Ledger.Slot (Slot (Slot), SlotRange)
-import Plutus.V1.Ledger.Interval (Extended (Finite), Interval (Interval), LowerBound (LowerBound),
-                                  UpperBound (UpperBound), interval, member)
-import Plutus.V1.Ledger.Time (POSIXTime (POSIXTime, getPOSIXTime), POSIXTimeRange)
+import PlutusLedgerApi.V1.Interval (Extended (Finite), Interval (Interval), LowerBound (LowerBound),
+                                    UpperBound (UpperBound), interval, member)
+import PlutusLedgerApi.V1.Time (POSIXTime (POSIXTime, getPOSIXTime), POSIXTimeRange)
 import PlutusTx.Lift (makeLift)
 import PlutusTx.Prelude (Integer, divide, fmap, ($), (*), (+), (-), (.))
 import Prelude (Eq, IO, Show, (<$>))