diff --git a/cabal.project b/cabal.project index 6c8099749c..71f78ca188 100644 --- a/cabal.project +++ b/cabal.project @@ -20,11 +20,11 @@ packages: cardano-api cardano-api-gen --- package cardano-api --- ghc-options: -Werror --- --- package cardano-api-gen --- ghc-options: -Werror +package cardano-api + ghc-options: -Werror + +package cardano-api-gen + ghc-options: -Werror package cryptonite -- Using RDRAND instead of /dev/urandom as an entropy source for key diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 392740555f..f513600a60 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -151,6 +151,7 @@ import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.Hash.Class as CRYPTO import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.BaseTypes as Ledger import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) @@ -897,6 +898,9 @@ genRationalInt64 = genEpochNo :: Gen EpochNo genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10) +genEpochInterval :: Gen Ledger.EpochInterval +genEpochInterval = Ledger.EpochInterval <$> Gen.word32 (Range.linear 0 10) + genPraosNonce :: Gen PraosNonce genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) @@ -917,7 +921,7 @@ genProtocolParameters era = do protocolParamStakeAddressDeposit <- genLovelace protocolParamStakePoolDeposit <- genLovelace protocolParamMinPoolCost <- genLovelace - protocolParamPoolRetireMaxEpoch <- genEpochNo + protocolParamPoolRetireMaxEpoch <- genEpochInterval protocolParamStakePoolTargetNum <- genNat protocolParamPoolPledgeInfluence <- genRationalInt64 protocolParamMonetaryExpansion <- genRational @@ -953,7 +957,7 @@ genProtocolParametersUpdate era = do protocolUpdateStakeAddressDeposit <- Gen.maybe genLovelace protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace protocolUpdateMinPoolCost <- Gen.maybe genLovelace - protocolUpdatePoolRetireMaxEpoch <- Gen.maybe genEpochNo + protocolUpdatePoolRetireMaxEpoch <- Gen.maybe genEpochInterval protocolUpdateStakePoolTargetNum <- Gen.maybe genNat protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64 protocolUpdateMonetaryExpansion <- Gen.maybe genRational diff --git a/cardano-api/internal/Cardano/Api/Address.hs b/cardano-api/internal/Cardano/Api/Address.hs index 99c676d86e..cee1670820 100644 --- a/cardano-api/internal/Cardano/Api/Address.hs +++ b/cardano-api/internal/Cardano/Api/Address.hs @@ -224,7 +224,7 @@ instance SerialiseAsRawBytes (Address ByronAddr) where $ addr deserialiseFromRawBytes (AsAddress AsByronAddr) bs = - case Shelley.deserialiseAddr bs :: Maybe (Shelley.Addr StandardCrypto) of + case Shelley.decodeAddr bs :: Maybe (Shelley.Addr StandardCrypto) of Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") Just Shelley.Addr{} -> Left (SerialiseAsRawBytesError "Unable to deserialise Address ByronAddr") Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> @@ -235,7 +235,7 @@ instance SerialiseAsRawBytes (Address ShelleyAddr) where Shelley.serialiseAddr (Shelley.Addr nw pc scr) deserialiseFromRawBytes (AsAddress AsShelleyAddr) bs = - case Shelley.deserialiseAddr bs of + case Shelley.decodeAddr bs of Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") Just Shelley.AddrBootstrap{} -> Left (SerialiseAsRawBytesError "Unable to deserialise bootstrap Address ShelleyAddr") Just (Shelley.Addr nw pc scr) -> Right (ShelleyAddress nw pc scr) @@ -330,7 +330,7 @@ instance SerialiseAsRawBytes AddressAny where serialiseToRawBytes (AddressShelley addr) = serialiseToRawBytes addr deserialiseFromRawBytes AsAddressAny bs = - case Shelley.deserialiseAddr bs of + case Shelley.decodeAddr bs of Nothing -> Left (SerialiseAsRawBytesError "Unable to deserialise AddressAny") Just (Shelley.AddrBootstrap (Shelley.BootstrapAddress addr)) -> Right (AddressByron (ByronAddress addr)) diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 9bab83f3d6..37cecaefd7 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs index 79cc8c1790..f5b6e097fe 100644 --- a/cardano-api/internal/Cardano/Api/Convenience/Construction.hs +++ b/cardano-api/internal/Cardano/Api/Convenience/Construction.hs @@ -54,7 +54,7 @@ constructBalancedTx :: () -> Map.Map StakeCredential Lovelace -> Map.Map (L.Credential L.DRepRole L.StandardCrypto) Lovelace -> [ShelleyWitnessSigningKey] - -> Either TxBodyErrorAutoBalance (Tx era) + -> Either (TxBodyErrorAutoBalance era) (Tx era) constructBalancedTx sbe txbodcontent changeAddr mOverrideWits utxo lpp ledgerEpochInfo systemStart stakePools stakeDelegDeposits drepDelegDeposits shelleyWitSigningKeys = do diff --git a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs index dbbc940c1a..d16c425468 100644 --- a/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/AlonzoEraOnwards.hs @@ -11,10 +11,12 @@ module Cardano.Api.Eon.AlonzoEraOnwards ( AlonzoEraOnwards(..) , alonzoEraOnwardsConstraints + , alonzoEraOnwardsPlutusConstraints , alonzoEraOnwardsToCardanoEra , alonzoEraOnwardsToShelleyBasedEra , AlonzoEraOnwardsConstraints + , AlonzoEraOnwardsPlutusConstraints ) where import Cardano.Api.Eon.ShelleyBasedEra @@ -26,7 +28,7 @@ import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C -import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as L +import qualified Cardano.Ledger.Alonzo.Plutus.Context as Plutus import qualified Cardano.Ledger.Alonzo.Scripts as L import qualified Cardano.Ledger.Alonzo.Tx as L import qualified Cardano.Ledger.Alonzo.TxWits as L @@ -35,7 +37,6 @@ import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.Mary.Value as L -import qualified Cardano.Ledger.Plutus.Language as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus @@ -105,8 +106,8 @@ type AlonzoEraOnwardsConstraints era = , Typeable era ) -alonzoEraOnwardsConstraints :: () - => AlonzoEraOnwards era +alonzoEraOnwardsConstraints + :: AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a alonzoEraOnwardsConstraints = \case @@ -114,6 +115,17 @@ alonzoEraOnwardsConstraints = \case AlonzoEraOnwardsBabbage -> id AlonzoEraOnwardsConway -> id +type AlonzoEraOnwardsPlutusConstraints era = Plutus.EraPlutusContext (ShelleyLedgerEra era) + +alonzoEraOnwardsPlutusConstraints + :: AlonzoEraOnwards era + -> (AlonzoEraOnwardsPlutusConstraints era => a) + -> a +alonzoEraOnwardsPlutusConstraints = \case + AlonzoEraOnwardsAlonzo -> id + AlonzoEraOnwardsBabbage -> id + AlonzoEraOnwardsConway -> id + alonzoEraOnwardsToCardanoEra :: AlonzoEraOnwards era -> CardanoEra era alonzoEraOnwardsToCardanoEra = shelleyBasedToCardanoEra . alonzoEraOnwardsToShelleyBasedEra diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index c985ec4d81..cebe6d9110 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -26,7 +26,6 @@ import Cardano.Binary import qualified Cardano.Crypto.Hash.Blake2b as Blake2b import qualified Cardano.Crypto.Hash.Class as C import qualified Cardano.Crypto.VRF as C -import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as L import qualified Cardano.Ledger.Alonzo.Scripts as L import qualified Cardano.Ledger.Alonzo.UTxO as L import qualified Cardano.Ledger.Api as L @@ -36,7 +35,6 @@ import qualified Cardano.Ledger.Conway.Governance as L import qualified Cardano.Ledger.Conway.PParams as L import qualified Cardano.Ledger.Conway.TxCert as L import qualified Cardano.Ledger.Mary.Value as L -import qualified Cardano.Ledger.Plutus.Language as L import qualified Cardano.Ledger.SafeHash as L import qualified Cardano.Ledger.UTxO as L import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 716e2f1423..3a45984c8c 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 3f4d3ea4c7..92de268726 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -44,6 +45,7 @@ module Cardano.Api.Fees ( import Cardano.Api.Address import Cardano.Api.Certificate +import Cardano.Api.Eon.AlonzoEraOnwards import Cardano.Api.Eon.BabbageEraOnwards import Cardano.Api.Eon.MaryEraOnwards import Cardano.Api.Eon.ShelleyBasedEra @@ -63,13 +65,12 @@ import Cardano.Api.Value import qualified Cardano.Binary as CBOR import qualified Cardano.Chain.Common as Byron import qualified Cardano.Ledger.Alonzo.Core as Ledger -import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Alonzo +import qualified Cardano.Ledger.Alonzo.Plutus.Context as Plutus import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Coin as Ledger -import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.Credential as Ledger (Credential) import qualified Cardano.Ledger.Crypto as Ledger import qualified Cardano.Ledger.Keys as Ledger @@ -397,7 +398,7 @@ instance Error ScriptExecutionError where ScriptErrorMissingCostModel language -> "No cost model was found for language " <> pshow language -data TransactionValidityError = +data TransactionValidityError era where -- | The transaction validity interval is too far into the future. -- -- Transactions with Plutus scripts need to have a validity interval that is @@ -414,15 +415,20 @@ data TransactionValidityError = -- hours beyond the current time. This effectively means we cannot submit -- check or submit transactions that use Plutus scripts that have the end -- of their validity interval more than 36 hours into the future. - TransactionValidityIntervalError Consensus.PastHorizonException + TransactionValidityIntervalError + :: Consensus.PastHorizonException -> TransactionValidityError era - -- | TransactionValidityTranslationError (Ledger.TranslationError Ledger.StandardCrypto (Ledger.Tx Ledger.StandardCrypto)) + TransactionValidityTranslationError + :: Plutus.EraPlutusContext (ShelleyLedgerEra era) + => Plutus.ContextError (ShelleyLedgerEra era) + -> TransactionValidityError era - | TransactionValidityCostModelError (Map AnyPlutusScriptVersion CostModel) String + TransactionValidityCostModelError + :: (Map AnyPlutusScriptVersion CostModel) -> String -> TransactionValidityError era -deriving instance Show TransactionValidityError +deriving instance Show (TransactionValidityError era) -instance Error TransactionValidityError where +instance Error (TransactionValidityError era) where prettyError = \case TransactionValidityIntervalError pastTimeHorizon -> mconcat @@ -444,8 +450,8 @@ instance Error TransactionValidityError where | otherwise = 0 -- This should be impossible. - -- TransactionValidityTranslationError errmsg -> - -- "Error translating the transaction context: " <> pshow errmsg + TransactionValidityTranslationError errmsg -> + "Error translating the transaction context: " <> pshow errmsg TransactionValidityCostModelError cModels err -> mconcat @@ -466,7 +472,7 @@ evaluateTransactionExecutionUnits :: forall era. () -> LedgerProtocolParameters era -> UTxO era -> TxBody era - -> Either TransactionValidityError + -> Either (TransactionValidityError era) (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody = case makeSignedTransaction' era [] txbody of @@ -479,22 +485,23 @@ evaluateTransactionExecutionUnitsShelley :: forall era. () -> LedgerProtocolParameters era -> UTxO era -> L.Tx (ShelleyLedgerEra era) - -> Either TransactionValidityError + -> Either (TransactionValidityError era) (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)) evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx = caseShelleyToMaryOrAlonzoEraOnwards (const (Right Map.empty)) - (\_ -> error "" - -- case L.evalTxExUnits pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart of - -- Left err -> error " --" -- Left (TransactionValidityTranslationError err) - -- Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) + (\w -> case alonzoEraOnwardsPlutusConstraints w $ L.evalTxExUnits pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart of + Left err -> Left $ alonzoEraOnwardsPlutusConstraints w + $ TransactionValidityTranslationError err + Right exmap -> Right (fromLedgerScriptExUnitsMap exmap) ) sbe where LedgerEpochInfo ledgerEpochInfo = epochInfo fromLedgerScriptExUnitsMap - :: Map Alonzo.RdmrPtr (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) + :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) + => Map Alonzo.RdmrPtr (Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) Alonzo.ExUnits) -> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits) fromLedgerScriptExUnitsMap exmap = @@ -503,8 +510,10 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc bimap fromAlonzoScriptExecutionError fromAlonzoExUnits exunitsOrFailure) | (rdmrptr, exunitsOrFailure) <- Map.toList exmap ] - fromAlonzoScriptExecutionError :: L.TransactionScriptFailure (ShelleyLedgerEra era) - -> ScriptExecutionError + fromAlonzoScriptExecutionError + :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) + => L.TransactionScriptFailure (ShelleyLedgerEra era) + -> ScriptExecutionError fromAlonzoScriptExecutionError = shelleyBasedEraConstraints sbe $ \case L.UnknownTxIn txin -> ScriptErrorMissingTxIn txin' @@ -512,39 +521,35 @@ evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtoc L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin' where txin' = fromShelleyTxIn txin L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh) - --L.ValidationFailure _ -> - -- ScriptErrorEvaluationFailed err logs - -- L.ValidationFailure _ -> - -- ScriptErrorEvaluationFailed err logs - --L.ValidationFailure _ -> - -- ScriptErrorEvaluationFailed err logs + L.ValidationFailure _ evalErr logs _ -> + -- TODO: Include additional information from ValidationFailure + ScriptErrorEvaluationFailed evalErr logs + L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow - -- This is only possible for spending scripts and occurs when - -- we attempt to spend a key witnessed tx input with a Plutus - -- script witness. - -- L.RedeemerNotNeeded rdmrPtr scriptHash -> - -- ScriptErrorNotPlutusWitnessedTxIn - -- (fromAlonzoRdmrPtr rdmrPtr) - -- (fromShelleyScriptHash scriptHash) L.RedeemerPointsToUnknownScriptHash rdmrPtr -> ScriptErrorRedeemerPointsToUnknownScriptHash $ fromAlonzoRdmrPtr rdmrPtr -- This should not occur while using cardano-cli because we zip together -- the Plutus script and the use site (txin, certificate etc). Therefore -- the redeemer pointer will always point to a Plutus script. - --L.MissingScript rdmrPtr resolveable -> - -- let cnv1 Plutus.Plutus - -- { Plutus.plutusLanguage = lang - -- , Plutus.plutusScript = Alonzo.BinaryPlutus bytes - -- } = (bytes, lang) - -- cnv2 (purpose, mbScript, scriptHash) = (purpose, fmap cnv1 mbScript, scriptHash) - -- in - -- ScriptErrorMissingScript rdmrPtr - -- $ ResolvablePointers sbe - -- $ Map.map cnv2 resolveable + L.MissingScript rdmrPtr resolveable -> + let cnv2 (purpose, mbScript, scriptHash) = (purpose, fmap extractPlutusScriptAndLanguage mbScript, scriptHash) + in + ScriptErrorMissingScript rdmrPtr + $ ResolvablePointers sbe + $ Map.map cnv2 resolveable L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l +extractPlutusScriptAndLanguage + :: Alonzo.AlonzoEraScript (ShelleyLedgerEra era) + => Alonzo.PlutusScript (ShelleyLedgerEra era) + -> (PlutusScriptBytes, Plutus.Language) +extractPlutusScriptAndLanguage p = + let bin = Plutus.unPlutusBinary $ Alonzo.plutusScriptBinary p + l = Alonzo.plutusScriptLanguage p + in (bin, l) + -- ---------------------------------------------------------------------------- -- Transaction balance -- @@ -596,7 +601,7 @@ evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits u -- | The possible errors that can arise from 'makeTransactionBodyAutoBalance'. -- -data TxBodyErrorAutoBalance = +data TxBodyErrorAutoBalance era = -- | The same errors that can arise from 'makeTransactionBody'. TxBodyError TxBodyError @@ -635,7 +640,7 @@ data TxBodyErrorAutoBalance = -- | The transaction validity interval is too far into the future. -- See 'TransactionValidityIntervalError' for details. - | TxBodyErrorValidityInterval TransactionValidityError + | TxBodyErrorValidityInterval (TransactionValidityError era) -- | The minimum spendable UTxO threshold has not been met. | TxBodyErrorMinUTxONotMet @@ -651,7 +656,7 @@ data TxBodyErrorAutoBalance = deriving Show -instance Error TxBodyErrorAutoBalance where +instance Error (TxBodyErrorAutoBalance era) where prettyError = \case TxBodyError err -> prettyError err @@ -717,7 +722,7 @@ handleExUnitsErrors :: ScriptValidity -- ^ Mark script as expected to pass or fail validation -> Map ScriptWitnessIndex ScriptExecutionError -> Map ScriptWitnessIndex ExecutionUnits - -> Either TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits) + -> Either (TxBodyErrorAutoBalance era) (Map ScriptWitnessIndex ExecutionUnits) handleExUnitsErrors ScriptValid failuresMap exUnitsMap = if null failures then Right exUnitsMap @@ -774,7 +779,7 @@ makeTransactionBodyAutoBalance :: forall era. () -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses - -> Either TxBodyErrorAutoBalance (BalancedTxBody era) + -> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era) makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits drepDelegDeposits utxo txbodycontent changeaddr mnkeys = shelleyBasedEraConstraints sbe $ do @@ -994,7 +999,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame -- of the outputs _ -> rest ++ [change] - balanceCheck :: Ledger.PParams (ShelleyLedgerEra era) -> TxOutValue era -> Either TxBodyErrorAutoBalance () + balanceCheck :: Ledger.PParams (ShelleyLedgerEra era) -> TxOutValue era -> Either (TxBodyErrorAutoBalance era) () balanceCheck bpparams balance | txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return () | txOutValueToLovelace balance < 0 = @@ -1016,7 +1021,7 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame checkMinUTxOValue :: TxOut CtxTx era -> Ledger.PParams (ShelleyLedgerEra era) - -> Either TxBodyErrorAutoBalance () + -> Either (TxBodyErrorAutoBalance era) () checkMinUTxOValue txout@(TxOut _ v _ _) bpp = do let minUTxO = calculateMinimumUTxO sbe txout bpp if txOutValueToLovelace v >= minUTxO @@ -1025,13 +1030,13 @@ makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParame substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era - -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) + -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) substituteExecutionUnits exUnitsMap = mapTxScriptWitnesses f where f :: ScriptWitnessIndex -> ScriptWitness witctx era - -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era) + -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era) f _ wit@SimpleScriptWitness{} = Right wit f idx (PlutusScriptWitness langInEra version script datum redeemer _) = case Map.lookup idx exUnitsMap of @@ -1043,9 +1048,9 @@ mapTxScriptWitnesses :: forall era. (forall witctx. ScriptWitnessIndex -> ScriptWitness witctx era - -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)) + -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) -> TxBodyContent BuildTx era - -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) + -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) mapTxScriptWitnesses f txbodycontent@TxBodyContent { txIns, txWithdrawals, @@ -1066,11 +1071,11 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { where mapScriptWitnessesTxIns :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] - -> Either TxBodyErrorAutoBalance [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] + -> Either (TxBodyErrorAutoBalance era) [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))] mapScriptWitnessesTxIns txins = let mappedScriptWitnesses :: [ ( TxIn - , Either TxBodyErrorAutoBalance (BuildTxWith BuildTx (Witness WitCtxTxIn era)) + , Either (TxBodyErrorAutoBalance era) (BuildTxWith BuildTx (Witness WitCtxTxIn era)) ) ] mappedScriptWitnesses = @@ -1091,13 +1096,13 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { mapScriptWitnessesWithdrawals :: TxWithdrawals BuildTx era - -> Either TxBodyErrorAutoBalance (TxWithdrawals BuildTx era) + -> Either (TxBodyErrorAutoBalance era) (TxWithdrawals BuildTx era) mapScriptWitnessesWithdrawals TxWithdrawalsNone = Right TxWithdrawalsNone mapScriptWitnessesWithdrawals (TxWithdrawals supported withdrawals) = let mappedWithdrawals :: [( StakeAddress , Lovelace - , Either TxBodyErrorAutoBalance (BuildTxWith BuildTx (Witness WitCtxStake era)) + , Either (TxBodyErrorAutoBalance era) (BuildTxWith BuildTx (Witness WitCtxStake era)) )] mappedWithdrawals = [ (addr, withdrawal, BuildTxWith <$> mappedWitness) @@ -1113,20 +1118,20 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { ) mappedWithdrawals where adjustWitness - :: (ScriptWitness witctx era -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era)) + :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)) -> Witness witctx era - -> Either TxBodyErrorAutoBalance (Witness witctx era) + -> Either (TxBodyErrorAutoBalance era) (Witness witctx era) adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness' mapScriptWitnessesCertificates :: TxCertificates BuildTx era - -> Either TxBodyErrorAutoBalance (TxCertificates BuildTx era) + -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era) mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone mapScriptWitnessesCertificates (TxCertificates supported certs (BuildTxWith witnesses)) = let mappedScriptWitnesses - :: [(StakeCredential, Either TxBodyErrorAutoBalance (Witness WitCtxStake era))] + :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] mappedScriptWitnesses = [ (stakecred, ScriptWitness ctx <$> witness') -- The certs are indexed in list order @@ -1145,13 +1150,13 @@ mapTxScriptWitnesses f txbodycontent@TxBodyContent { mapScriptWitnessesMinting :: TxMintValue BuildTx era - -> Either TxBodyErrorAutoBalance (TxMintValue BuildTx era) + -> Either (TxBodyErrorAutoBalance era) (TxMintValue BuildTx era) mapScriptWitnessesMinting TxMintNone = Right TxMintNone mapScriptWitnessesMinting (TxMintValue supported value (BuildTxWith witnesses)) = --TxMintValue supported value $ BuildTxWith $ Map.fromList let mappedScriptWitnesses - :: [(PolicyId, Either TxBodyErrorAutoBalance (ScriptWitness WitCtxMint era))] + :: [(PolicyId, Either (TxBodyErrorAutoBalance era) (ScriptWitness WitCtxMint era))] mappedScriptWitnesses = [ (policyid, witness') -- The minting policies are indexed in policy id order in the value diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index a5280f9302..ac48c087b0 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -91,7 +91,7 @@ toGovernanceAction sbe = InfoAct -> Gov.InfoAction TreasuryWithdrawal withdrawals -> - let m = Map.fromList [(L.mkRwdAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals] + let m = Map.fromList [(L.RewardAcnt nw (toShelleyStakeCredential sc), toShelleyLovelace l) | (nw,sc,l) <- withdrawals] in Gov.TreasuryWithdrawals m InitiateHardfork prevGovId pVer -> Gov.HardForkInitiation prevGovId pVer @@ -165,7 +165,7 @@ createProposalProcedure sbe nw dep (StakeKeyHash retAddrh) govAct anchor = shelleyBasedEraConstraints sbe $ Proposal Gov.ProposalProcedure { Gov.pProcDeposit = toShelleyLovelace dep - , Gov.pProcReturnAddr = L.mkRwdAcnt nw (L.KeyHashObj retAddrh) + , Gov.pProcReturnAddr = L.RewardAcnt nw (L.KeyHashObj retAddrh) , Gov.pProcGovAction = toGovernanceAction sbe govAct , Gov.pProcAnchor = anchor } diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs index 7e17cab3eb..c4d026cc50 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/LedgerEvent.hs @@ -24,6 +24,7 @@ import qualified Cardano.Ledger.Core as Ledger.Core import qualified Cardano.Ledger.Credential as Ledger import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Keys as Ledger +import Cardano.Ledger.Plutus.Evaluate (PlutusWithContext) import Cardano.Ledger.Shelley.Rewards (Reward) import qualified Cardano.Ledger.TxIn as Ledger @@ -57,9 +58,9 @@ data LedgerEvent | -- | Pools have been reaped and deposits refunded. PoolReap PoolReapDetails -- | A number of succeeded Plutus script evaluations. - | SuccessfulPlutusScript -- (NonEmpty PlutusDebug) + | SuccessfulPlutusScript (NonEmpty PlutusWithContext) -- | A number of failed Plutus script evaluations. - | FailedPlutusScript --(NonEmpty PlutusDebug) + | FailedPlutusScript (NonEmpty PlutusWithContext) -- Only events available on the Conway Era. diff --git a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs index 37ea1216db..869fed1b8c 100644 --- a/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs +++ b/cardano-api/internal/Cardano/Api/LedgerEvents/Rule/BBODY/UTXOW.hs @@ -29,8 +29,8 @@ handleAlonzoOnwardsUTxOWEvent (WrappedShelleyEraEvent (Shelley.UtxoEvent (UtxosE case utxoEvent of Alonzo.AlonzoPpupToUtxosEvent{} -> Nothing Alonzo.TotalDeposits{} -> Nothing - Alonzo.SuccessfulPlutusScriptsEvent e -> error "" -- Just $ SuccessfulPlutusScript e - Alonzo.FailedPlutusScriptsEvent e -> error "" -- Just $ FailedPlutusScript e + Alonzo.SuccessfulPlutusScriptsEvent e -> Just $ SuccessfulPlutusScript e + Alonzo.FailedPlutusScriptsEvent e -> Just $ FailedPlutusScript e handlePreAlonzoUTxOWEvent :: Event (Ledger.Core.EraRule "UTXO" ledgerera) ~ Shelley.UtxoEvent ledgerera diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index 98785b01f0..9afc2cf0ca 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -198,6 +199,9 @@ deriving instance Data CBOR.DeserialiseFailure deriving instance Data Bech32.DecodingError deriving instance Data Bech32.CharPosition +deriving newtype instance ToCBOR Ledger.EpochInterval +deriving newtype instance FromCBOR Ledger.EpochInterval + -- Orphan instances involved in the JSON output of the API queries. -- We will remove/replace these as we provide more API wrapper types diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 13c70421cf..380d418dcf 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -18,6 +18,7 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE InstanceSigs #-} {- HLINT ignore "Redundant ==" -} {- HLINT ignore "Use mapM" -} @@ -543,7 +544,7 @@ data ProtocolParameters = -- | The maximum number of epochs into the future that stake pools -- are permitted to schedule a retirement. -- - protocolParamPoolRetireMaxEpoch :: EpochNo, + protocolParamPoolRetireMaxEpoch :: Ledger.EpochInterval, -- | The equilibrium target number of stake pools. -- @@ -771,7 +772,7 @@ data ProtocolParametersUpdate = -- | The maximum number of epochs into the future that stake pools -- are permitted to schedule a retirement. -- - protocolUpdatePoolRetireMaxEpoch :: Maybe EpochNo, + protocolUpdatePoolRetireMaxEpoch :: Maybe Ledger.EpochInterval, -- | The equilibrium target number of stake pools. -- @@ -914,6 +915,7 @@ instance Monoid ProtocolParametersUpdate where } instance ToCBOR ProtocolParametersUpdate where + toCBOR :: ProtocolParametersUpdate -> CBOR.Encoding toCBOR ProtocolParametersUpdate{..} = CBOR.encodeListLen 26 <> toCBOR protocolUpdateProtocolVersion @@ -941,7 +943,6 @@ instance ToCBOR ProtocolParametersUpdate where <> toCBOR protocolUpdateCollateralPercent <> toCBOR protocolUpdateMaxCollateralInputs <> toCBOR protocolUpdateUTxOCostPerByte - instance FromCBOR ProtocolParametersUpdate where fromCBOR = do CBOR.enforceSize "ProtocolParametersUpdate" 26 @@ -1234,7 +1235,7 @@ toShelleyCommonPParamsUpdate (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateStakeAddressDeposit) & ppuPoolDepositL .~ (toShelleyLovelace <$> noInlineMaybeToStrictMaybe protocolUpdateStakePoolDeposit) - & ppuEMaxL .~ noInlineMaybeToStrictMaybe undefined -- protocolUpdatePoolRetireMaxEpoch + & ppuEMaxL .~ noInlineMaybeToStrictMaybe protocolUpdatePoolRetireMaxEpoch & ppuNOptL .~ noInlineMaybeToStrictMaybe protocolUpdateStakePoolTargetNum & ppuA0L .~ noInlineMaybeToStrictMaybe a0 @@ -1427,7 +1428,7 @@ fromShelleyCommonPParamsUpdate ppu = strictMaybeToMaybe (ppu ^. ppuPoolDepositL) , protocolUpdateMinPoolCost = fromShelleyLovelace <$> strictMaybeToMaybe (ppu ^. ppuMinPoolCostL) - , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe undefined -- (ppu ^. ppuEMaxL) + , protocolUpdatePoolRetireMaxEpoch = strictMaybeToMaybe (ppu ^. ppuEMaxL) , protocolUpdateStakePoolTargetNum = strictMaybeToMaybe (ppu ^. ppuNOptL) , protocolUpdatePoolPledgeInfluence = Ledger.unboundRational <$> strictMaybeToMaybe (ppu ^. ppuA0L) @@ -1569,7 +1570,7 @@ toShelleyCommonPParams & ppMaxBHSizeL .~ protocolParamMaxBlockHeaderSize & ppKeyDepositL .~ toShelleyLovelace protocolParamStakeAddressDeposit & ppPoolDepositL .~ toShelleyLovelace protocolParamStakePoolDeposit - & ppEMaxL .~ undefined -- protocolParamPoolRetireMaxEpoch + & ppEMaxL .~ protocolParamPoolRetireMaxEpoch & ppNOptL .~ protocolParamStakePoolTargetNum & ppA0L .~ a0 & ppRhoL .~ rho @@ -1720,7 +1721,7 @@ fromShelleyCommonPParams pp = , protocolParamStakeAddressDeposit = fromShelleyLovelace (pp ^. ppKeyDepositL) , protocolParamStakePoolDeposit = fromShelleyLovelace (pp ^. ppPoolDepositL) , protocolParamMinPoolCost = fromShelleyLovelace (pp ^. ppMinPoolCostL) - , protocolParamPoolRetireMaxEpoch = undefined -- pp ^. ppEMaxL + , protocolParamPoolRetireMaxEpoch = pp ^. ppEMaxL , protocolParamStakePoolTargetNum = pp ^. ppNOptL , protocolParamPoolPledgeInfluence = Ledger.unboundRational (pp ^. ppA0L) , protocolParamMonetaryExpansion = Ledger.unboundRational (pp ^. ppRhoL) diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 124da24eb4..f16353d84a 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -130,8 +130,10 @@ import qualified Cardano.Binary as CBOR import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Ledger.Allegra.Scripts as Timelock import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo +import qualified Cardano.Ledger.Babbage.Scripts as Babbage import Cardano.Ledger.BaseTypes (StrictMaybe (..)) import qualified Cardano.Ledger.Binary as Binary (decCBOR, decodeFullAnnotator) +import qualified Cardano.Ledger.Conway.Scripts as Conway import Cardano.Ledger.Core (Era (EraCrypto)) import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Keys as Shelley @@ -925,23 +927,10 @@ fromAlonzoExUnits Alonzo.ExUnits{Alonzo.exUnitsSteps, Alonzo.exUnitsMem} = -- Alonzo mediator pattern -- --- pattern AlonzoPlutusScript :: Plutus.Language -> ShortByteString -> Alonzo.AlonzoScript era --- pattern AlonzoPlutusScript lang script = Alonzo.PlutusScript (Plutus.Plutus {Plutus.plutusLanguage = lang, Plutus.plutusScript = Alonzo.BinaryPlutus script}) +pattern PlutusScriptBinary :: Plutus.PlutusLanguage l => ShortByteString -> Plutus.Plutus l +pattern PlutusScriptBinary script = Plutus.Plutus (Plutus.PlutusBinary script) -pattern AlonzoTimelockScript :: Timelock.Timelock era -> Alonzo.AlonzoScript era -pattern AlonzoTimelockScript script = Alonzo.TimelockScript script - --- | NOT EXPORTED --- --- This exists solely to cause an pattern match checker warning if --- 'Alonzo.AlonzoScript' changes, which would mean the following @COMPLETE@ --- pramga may need to be updated. ---_completenessProof :: Alonzo.AlonzoScript era -> () ---_completenessProof = \case --- Alonzo.TimelockScript _ -> () --- Alonzo.PlutusScript (Plutus.Plutus _ (Alonzo.BinaryPlutus _)) -> () - ---{-# COMPLETE AlonzoTimelockScript, AlonzoPlutusScript #-} +{-# COMPLETE PlutusScriptBinary #-} -- ---------------------------------------------------------------------------- -- Script Hash @@ -984,17 +973,20 @@ hashScript (PlutusScript PlutusScriptV1 (PlutusScriptSerialised script)) = -- hash that. Later ledger eras have to be compatible anyway. ScriptHash . Ledger.hashScript @(ShelleyLedgerEra AlonzoEra) - $ error "" -- AlonzoPlutusScript Plutus.PlutusV1 script + . Alonzo.PlutusScript . Alonzo.AlonzoPlutusV1 . Plutus.Plutus + $ Plutus.PlutusBinary script hashScript (PlutusScript PlutusScriptV2 (PlutusScriptSerialised script)) = ScriptHash . Ledger.hashScript @(ShelleyLedgerEra BabbageEra) - $ error "" -- AlonzoPlutusScript Plutus.PlutusV2 script + . Alonzo.PlutusScript . Babbage.BabbagePlutusV2 . Plutus.Plutus + $ Plutus.PlutusBinary script hashScript (PlutusScript PlutusScriptV3 (PlutusScriptSerialised script)) = ScriptHash . Ledger.hashScript @(ShelleyLedgerEra ConwayEra) - $ error "" -- AlonzoPlutusScript Plutus.PlutusV3 script + . Alonzo.PlutusScript . Conway.ConwayPlutusV1 . Plutus.Plutus + $ Plutus.PlutusBinary script toShelleyScriptHash :: ScriptHash -> Shelley.ScriptHash StandardCrypto toShelleyScriptHash (ScriptHash h) = h @@ -1106,27 +1098,33 @@ toShelleyScript (ScriptInEra langInEra (SimpleScript script)) = SimpleScriptInShelley -> either (error . show) id (toShelleyMultiSig script) SimpleScriptInAllegra -> toAllegraTimelock script SimpleScriptInMary -> toAllegraTimelock script - SimpleScriptInAlonzo -> AlonzoTimelockScript (toAllegraTimelock script) - SimpleScriptInBabbage -> AlonzoTimelockScript (toAllegraTimelock script) - SimpleScriptInConway -> AlonzoTimelockScript (toAllegraTimelock script) + SimpleScriptInAlonzo -> Alonzo.TimelockScript (toAllegraTimelock script) + SimpleScriptInBabbage -> Alonzo.TimelockScript (toAllegraTimelock script) + SimpleScriptInConway -> Alonzo.TimelockScript (toAllegraTimelock script) toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV1 (PlutusScriptSerialised script))) = case langInEra of - PlutusScriptV1InAlonzo -> error "" -- AlonzoPlutusScript Plutus.PlutusV1 script - PlutusScriptV1InBabbage -> error "" -- AlonzoPlutusScript Plutus.PlutusV1 script - PlutusScriptV1InConway -> error "" -- AlonzoPlutusScript Plutus.PlutusV1 script + PlutusScriptV1InAlonzo -> + Alonzo.PlutusScript . Alonzo.AlonzoPlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV1InBabbage -> + Alonzo.PlutusScript . Babbage.BabbagePlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV1InConway -> + Alonzo.PlutusScript . Conway.ConwayPlutusV1 . Plutus.Plutus $ Plutus.PlutusBinary script toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV2 (PlutusScriptSerialised script))) = case langInEra of - PlutusScriptV2InBabbage -> error "" -- AlonzoPlutusScript Plutus.PlutusV2 script - PlutusScriptV2InConway -> error "" -- AlonzoPlutusScript Plutus.PlutusV2 script + PlutusScriptV2InBabbage -> + Alonzo.PlutusScript . Babbage.BabbagePlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script + PlutusScriptV2InConway -> + Alonzo.PlutusScript . Conway.ConwayPlutusV2 . Plutus.Plutus $ Plutus.PlutusBinary script toShelleyScript (ScriptInEra langInEra (PlutusScript PlutusScriptV3 (PlutusScriptSerialised script))) = case langInEra of - PlutusScriptV3InConway -> error "" -- AlonzoPlutusScript Plutus.PlutusV3 script + PlutusScriptV3InConway -> + Alonzo.PlutusScript . Conway.ConwayPlutusV3 . Plutus.Plutus $ Plutus.PlutusBinary script fromShelleyBasedScript :: ShelleyBasedEra era -> Ledger.Script (ShelleyLedgerEra era) @@ -1144,45 +1142,48 @@ fromShelleyBasedScript sbe script = . SimpleScript $ fromAllegraTimelock script ShelleyBasedEraAlonzo -> case script of - AlonzoTimelockScript s -> + Alonzo.PlutusScript (Alonzo.AlonzoPlutusV1 (PlutusScriptBinary s)) -> + ScriptInEra PlutusScriptV1InAlonzo + . PlutusScript PlutusScriptV1 + $ PlutusScriptSerialised s + Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInAlonzo . SimpleScript $ fromAllegraTimelock s - --AlonzoPlutusScript Plutus.PlutusV1 s -> - -- ScriptInEra PlutusScriptV1InAlonzo - -- . PlutusScript PlutusScriptV1 - -- $ PlutusScriptSerialised s - --AlonzoPlutusScript Plutus.PlutusV2 _ -> - -- error "fromShelleyBasedScript: PlutusV2 not supported in Alonzo era" - --AlonzoPlutusScript Plutus.PlutusV3 _ -> - -- error "fromShelleyBasedScript: PlutusV3 not supported in Alonzo era" ShelleyBasedEraBabbage -> case script of - AlonzoTimelockScript s -> + Alonzo.PlutusScript plutusV -> + case plutusV of + Babbage.BabbagePlutusV1 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV1InBabbage + . PlutusScript PlutusScriptV1 + $ PlutusScriptSerialised s + Babbage.BabbagePlutusV2 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV2InBabbage + . PlutusScript PlutusScriptV2 + $ PlutusScriptSerialised s + Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInBabbage - . SimpleScript $ fromAllegraTimelock s - --AlonzoPlutusScript Plutus.PlutusV1 s -> - -- ScriptInEra PlutusScriptV1InBabbage - -- . PlutusScript PlutusScriptV1 $ PlutusScriptSerialised s - --AlonzoPlutusScript Plutus.PlutusV2 s -> - -- ScriptInEra PlutusScriptV2InBabbage - -- . PlutusScript PlutusScriptV2 $ PlutusScriptSerialised s - --AlonzoPlutusScript Plutus.PlutusV3 _ -> - -- error "fromShelleyBasedScript: PlutusV3 not supported in Babbage era" + . SimpleScript $ fromAllegraTimelock s ShelleyBasedEraConway -> case script of - AlonzoTimelockScript s -> + Alonzo.PlutusScript plutusV -> + case plutusV of + Conway.ConwayPlutusV1 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV1InConway + . PlutusScript PlutusScriptV1 + $ PlutusScriptSerialised s + Conway.ConwayPlutusV2 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV2InConway + . PlutusScript PlutusScriptV2 + $ PlutusScriptSerialised s + Conway.ConwayPlutusV3 (PlutusScriptBinary s) -> + ScriptInEra PlutusScriptV3InConway + . PlutusScript PlutusScriptV3 + $ PlutusScriptSerialised s + Alonzo.TimelockScript s -> ScriptInEra SimpleScriptInConway - . SimpleScript $ fromAllegraTimelock s - --AlonzoPlutusScript Plutus.PlutusV1 s -> - -- ScriptInEra PlutusScriptV1InConway - -- . PlutusScript PlutusScriptV1 $ PlutusScriptSerialised s - --AlonzoPlutusScript Plutus.PlutusV2 s -> - -- ScriptInEra PlutusScriptV2InConway - -- . PlutusScript PlutusScriptV2 $ PlutusScriptSerialised s - --AlonzoPlutusScript Plutus.PlutusV3 s -> - -- ScriptInEra PlutusScriptV3InConway - -- . PlutusScript PlutusScriptV3 $ PlutusScriptSerialised s + . SimpleScript $ fromAllegraTimelock s data MultiSigError = MultiSigErrorTimelockNotsupported deriving Show diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs index ad31d40c04..4087dccf90 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/ErrorsSpec.hs @@ -38,7 +38,9 @@ import qualified Cardano.Crypto.Seed as Crypto import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Ledger import qualified Cardano.Ledger.Alonzo.Scripts as Ledger import qualified Cardano.Ledger.Alonzo.TxWits as Ledger +import qualified Cardano.Ledger.Api.Era as Ledger import qualified Cardano.Ledger.Coin as L +import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Plutus.Language as Plutus import qualified PlutusCore.Evaluation.Machine.CostModelInterface as Plutus import qualified PlutusLedgerApi.Common as Plutus hiding (PlutusV2) @@ -273,10 +275,13 @@ test_TextEnvelopeError = , TextEnvelopeAesonDecodeError string ] +testPastHorizonValue :: Ledger.ContextError (Ledger.AlonzoEra StandardCrypto) +testPastHorizonValue = Ledger.TimeTranslationPastHorizon text + test_TransactionValidityError :: TestTree test_TransactionValidityError = testAllErrorMessages_ "Cardano.Api.Fees" "TransactionValidityError" - [ ("TransactionValidityTranslationError", undefined ) --TransactionValidityTranslationError $ Ledger.TimeTranslationPastHorizon text) + [ ("TransactionValidityTranslationError", TransactionValidityTranslationError testPastHorizonValue) , ("TransactionValidityCostModelError", TransactionValidityCostModelError (Map.fromList [(AnyPlutusScriptVersion PlutusScriptV2, costModel)]) string) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs index 9cb07b925f..f30958ef78 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Ledger.hs @@ -10,6 +10,7 @@ import Cardano.Api.Shelley import Cardano.Ledger.Address (deserialiseAddr, serialiseAddr) import qualified Cardano.Ledger.Api as L +import Cardano.Ledger.Api.Tx.Address import Cardano.Ledger.Crypto import Cardano.Ledger.SafeHash @@ -32,7 +33,7 @@ prop_roundtrip_Address_CBOR :: Property prop_roundtrip_Address_CBOR = H.property $ do -- If this fails, FundPair and ShelleyGenesis can also fail. addr <- H.forAll (arbitrary @(L.Addr StandardCrypto)) - H.tripping addr serialiseAddr deserialiseAddr + H.tripping addr serialiseAddr decodeAddr -- prop_original_scriptdata_bytes_preserved and prop_roundtrip_scriptdata_plutusdata -- allow us to generate a 'HashableScriptData' value from JSON with the original bytes being