From 79afc958961cfb75fac2ec797ff77bf7624b2341 Mon Sep 17 00:00:00 2001 From: paolino Date: Wed, 20 Mar 2024 18:31:15 +0000 Subject: [PATCH] Bogus fixes for balance-tx --- lib/balance-tx/cardano-balance-tx.cabal | 1 + .../lib/internal/Internal/Cardano/Write/Tx.hs | 27 +++-- .../Internal/Cardano/Write/Tx/Balance.hs | 7 +- .../Internal/Cardano/Write/Tx/Redeemers.hs | 102 ++++++++++++------ .../Internal/Cardano/Write/Tx/BalanceSpec.hs | 56 ++++++---- 5 files changed, 131 insertions(+), 62 deletions(-) diff --git a/lib/balance-tx/cardano-balance-tx.cabal b/lib/balance-tx/cardano-balance-tx.cabal index 2af6d80ef33..e0e3403ff09 100644 --- a/lib/balance-tx/cardano-balance-tx.cabal +++ b/lib/balance-tx/cardano-balance-tx.cabal @@ -119,6 +119,7 @@ test-suite test , cardano-ledger-api , cardano-ledger-babbage:{cardano-ledger-babbage, testlib} , cardano-ledger-byron + , cardano-ledger-conway , cardano-ledger-conway:testlib , cardano-ledger-core , cardano-ledger-mary:testlib diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx.hs index f6552f2ccbc..371c67bf18c 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx.hs @@ -16,6 +16,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} +-- remove TODO node890 +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + -- | -- Copyright: © 2022 IOHK -- License: Apache-2.0 @@ -153,12 +158,12 @@ import Cardano.Crypto.Hash import Cardano.Ledger.Allegra.Scripts ( translateTimelock ) -import Cardano.Ledger.Alonzo.Plutus.TxInfo +import Cardano.Ledger.Alonzo.Plutus.Context ( EraPlutusContext - , ExtendedUTxO ) import Cardano.Ledger.Alonzo.Scripts - ( AlonzoScript (..) + ( AlonzoEraScript + , AlonzoScript (..) ) import Cardano.Ledger.Alonzo.TxWits ( AlonzoTxWits @@ -344,22 +349,25 @@ type RecentEraConstraints era = , Core.Tx era ~ Babbage.AlonzoTx era , Core.Value era ~ Value , Core.TxWits era ~ AlonzoTxWits era - , ExtendedUTxO era + -- , ExtendedUTxO era , Alonzo.AlonzoEraPParams era , Ledger.AlonzoEraTx era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , EraPlutusContext 'PlutusV1 era + , AlonzoEraScript era + -- , EraPlutusContext 'PlutusV1 era , Eq (TxOut era) , Ledger.Crypto (Core.EraCrypto era) , Show (TxOut era) , Show (Core.Tx era) , Eq (Core.Tx era) , Babbage.BabbageEraTxBody era + , Alonzo.AlonzoEraTxBody era , Shelley.EraUTxO era , Show (TxOut era) , Eq (TxOut era) , Show (PParams era) , Show (Script era) + , EraPlutusContext era ) -- | Returns a proof that the given era is a recent era. @@ -535,7 +543,7 @@ type ScriptHash = Core.ScriptHash StandardCrypto type Value = MaryValue StandardCrypto unsafeAddressFromBytes :: ByteString -> Address -unsafeAddressFromBytes bytes = case Ledger.deserialiseAddr bytes of +unsafeAddressFromBytes bytes = case Ledger.decodeAddr bytes of Just addr -> addr Nothing -> error "unsafeAddressFromBytes: failed to deserialise" @@ -599,8 +607,8 @@ recentEraToBabbageTxOut (TxOutInRecentEra addr val datum mscript) = castScript = \case Alonzo.TimelockScript timelockEra -> Alonzo.TimelockScript (translateTimelock timelockEra) - Alonzo.PlutusScript bs -> - Alonzo.PlutusScript bs + Alonzo.PlutusScript _bs -> + Alonzo.PlutusScript (error "TODO node890") -- -- MinimumUTxO @@ -804,7 +812,8 @@ evaluateMinimumFee pp tx kwc = KeyWitnessCounts {nKeyWits, nBootstrapWits} = kwc mainFee :: Coin - mainFee = Shelley.evaluateTransactionFee pp tx nKeyWits + mainFee = error "TODO node890" + -- Shelley.evaluateTransactionFee pp tx nKeyWits FeePerByte feePerByte = getFeePerByte pp diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs index f1e63d67ac7..4862d4a5a73 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Balance.hs @@ -161,7 +161,8 @@ import Data.Group ( Group (invert) ) import Data.IntCast - ( intCastMaybe + ( intCast + , intCastMaybe ) import Data.List.NonEmpty ( NonEmpty (..) @@ -392,7 +393,7 @@ data ErrBalanceTx era | ErrBalanceTxInsufficientCollateral (ErrBalanceTxInsufficientCollateralError era) | ErrBalanceTxConflictingNetworks - | ErrBalanceTxAssignRedeemers ErrAssignRedeemers + | ErrBalanceTxAssignRedeemers (ErrAssignRedeemers era) | ErrBalanceTxInternalError (ErrBalanceTxInternalError era) | ErrBalanceTxInputResolutionConflicts (NonEmpty (TxOut era, TxOut era)) @@ -824,7 +825,7 @@ balanceTransactionWithSelectionStrategyAndNoZeroAdaAdjustment -> Tx era -> ExceptT (ErrBalanceTx era) m (Tx era) guardTxSize witCount tx = do - let maxSize = W.TxSize (pp ^. ppMaxTxSizeL) + let maxSize = W.TxSize $ intCast (pp ^. ppMaxTxSizeL) when (estimateSignedTxSize pp witCount tx > maxSize) $ throwE ErrBalanceTxMaxSizeLimitExceeded pure tx diff --git a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Redeemers.hs b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Redeemers.hs index f0c9eed36ed..af76f0b1ce8 100644 --- a/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Redeemers.hs +++ b/lib/balance-tx/lib/internal/Internal/Cardano/Write/Tx/Redeemers.hs @@ -4,9 +4,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {- HLINT ignore "Use <$>" -} -- | @@ -22,11 +24,12 @@ module Internal.Cardano.Write.Tx.Redeemers import Prelude -import Cardano.Ledger.Alonzo.Plutus.TxInfo - ( TranslationError +import Cardano.Ledger.Alonzo.Plutus.Context + ( EraPlutusContext (..) ) import Cardano.Ledger.Api - ( Tx + ( AsItem (..) + , Tx , bodyTxL , rdmrsTxWitsL , scriptIntegrityHashTxBodyL @@ -79,6 +82,9 @@ import Data.Map.Strict ( Map , (!) ) +import Data.Word + ( Word32 + ) import Fmt ( Buildable (..) ) @@ -89,8 +95,8 @@ import Internal.Cardano.Write.Tx ( IsRecentEra (..) , PParams , PolicyId + , RecentEra (..) , RewardAccount - , StandardCrypto , TxIn , UTxO ) @@ -100,26 +106,30 @@ import Internal.Cardano.Write.Tx.TimeTranslation , systemStartTime ) -import qualified Cardano.Ledger.Alonzo.PlutusScriptApi as Alonzo import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo import qualified Cardano.Ledger.Alonzo.Tx as Alonzo +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo +import qualified Cardano.Ledger.Api as Alonzo +import qualified Cardano.Ledger.Api as Conway import qualified Cardano.Ledger.Api as Ledger -import qualified Cardano.Ledger.Plutus.Data as Alonzo import qualified Data.ByteString.Lazy as BL import qualified Data.Map as Map import qualified Data.Map.Merge.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T -data ErrAssignRedeemers +data ErrAssignRedeemers era = ErrAssignRedeemersScriptFailure Redeemer String | ErrAssignRedeemersTargetNotFound Redeemer -- ^ The given redeemer target couldn't be located in the transaction. | ErrAssignRedeemersInvalidData Redeemer String -- ^ Redeemer's data isn't a valid Plutus' data. - | ErrAssignRedeemersTranslationError (TranslationError StandardCrypto) - deriving (Generic, Eq, Show) + | ErrAssignRedeemersTranslationError (ContextError era) + deriving (Generic) + +deriving instance Eq (ContextError era) => Eq (ErrAssignRedeemers era) +deriving instance Show (ContextError era) => Show (ErrAssignRedeemers era) assignScriptRedeemers :: forall era. IsRecentEra era @@ -128,7 +138,7 @@ assignScriptRedeemers -> UTxO era -> [Redeemer] -> Tx era - -> Either ErrAssignRedeemers (Tx era) + -> Either (ErrAssignRedeemers era) (Tx era) assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do flip execStateT tx $ do indexedRedeemers <- StateT assignNullRedeemers @@ -149,8 +159,8 @@ assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do -- 'Redeemer' type which is mapped to an 'Alonzo.ScriptPurpose'. assignNullRedeemers :: Tx era - -> Either ErrAssignRedeemers - ( Map Alonzo.RdmrPtr Redeemer + -> Either (ErrAssignRedeemers era) + ( Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) Redeemer , Tx era ) assignNullRedeemers ledgerTx = do @@ -164,9 +174,9 @@ assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do ) where parseRedeemer rd = do - let mPtr = Alonzo.rdptr - (view bodyTxL ledgerTx) - (toScriptPurpose rd) + let mPtr = Alonzo.redeemerPointer + (view bodyTxL ledgerTx) + (toScriptPurpose @era rd) ptr <- case mPtr of SNothing -> Left $ ErrAssignRedeemersTargetNotFound rd SJust ptr -> pure ptr @@ -180,31 +190,32 @@ assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do -- | Evaluate execution units of each script/redeemer in the transaction. -- This may fail for each script. evaluateExecutionUnits - :: Map Alonzo.RdmrPtr Redeemer + :: Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) Redeemer -> Tx era - -> Either ErrAssignRedeemers - (Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits)) + -> Either (ErrAssignRedeemers era) + (Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) + (Either (ErrAssignRedeemers era) Alonzo.ExUnits)) evaluateExecutionUnits indexedRedeemers ledgerTx = Ledger.evalTxExUnits pparams ledgerTx utxo epochInformation systemStart & bimap - ErrAssignRedeemersTranslationError - (hoistScriptFailure indexedRedeemers) + ErrAssignRedeemersTranslationError (hoistScriptFailure indexedRedeemers) hoistScriptFailure :: Show scriptFailure - => Map Alonzo.RdmrPtr Redeemer - -> Map Alonzo.RdmrPtr (Either scriptFailure a) - -> Map Alonzo.RdmrPtr (Either ErrAssignRedeemers a) + => Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) Redeemer + -> Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) (Either scriptFailure a) + -> Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) (Either (ErrAssignRedeemers era) a) hoistScriptFailure indexedRedeemers = Map.mapWithKey $ \ptr -> left $ \e -> ErrAssignRedeemersScriptFailure (indexedRedeemers ! ptr) (show e) -- | Change execution units for each redeemers in the transaction to what -- they ought to be. assignExecutionUnits - :: Map Alonzo.RdmrPtr (Either ErrAssignRedeemers Alonzo.ExUnits) + :: Map (Alonzo.PlutusPurpose Alonzo.AsIndex era) + (Either (ErrAssignRedeemers era) Alonzo.ExUnits) -> Tx era - -> Either ErrAssignRedeemers (Tx era) + -> Either (ErrAssignRedeemers era) (Tx era) assignExecutionUnits exUnits ledgerTx = do let Alonzo.Redeemers rdmrs = view (witsTxL . rdmrsTxWitsL) ledgerTx @@ -234,14 +245,14 @@ assignScriptRedeemers pparams timeTranslation utxo redeemers tx = do Alonzo.hashScriptIntegrity (Set.fromList $ Alonzo.getLanguageView pparams <$> langs) (Alonzo.txrdmrs wits) - (Alonzo.txdats wits) + (Alonzo.txdats' wits) where wits = Alonzo.wits ledgerTx langs = - [ l + [ Alonzo.plutusScriptLanguage plutus | (_hash, script) <- Map.toList (Alonzo.txscripts wits) , (not . Ledger.isNativeScript @era) script - , Just l <- [Alonzo.language script] + , Just plutus <- [Alonzo.toPlutusScript script] ] -- @@ -273,14 +284,41 @@ redeemerData = \case toScriptPurpose :: IsRecentEra era => Redeemer - -> Alonzo.ScriptPurpose era + -> Alonzo.PlutusPurpose AsItem era toScriptPurpose = \case RedeemerSpending _ txin -> - Alonzo.Spending txin + mkSpendingPurpose $ AsItem txin RedeemerMinting _ pid -> - Alonzo.Minting pid + mkMintingPurpose $ AsItem pid RedeemerRewarding _ acc -> - Alonzo.Rewarding acc + mkRewardingPurpose $ AsItem acc + +mkSpendingPurpose + :: forall era + . IsRecentEra era + => AsItem Word32 TxIn + -> Alonzo.PlutusPurpose AsItem era +mkSpendingPurpose = case recentEra @era of + RecentEraBabbage -> Alonzo.AlonzoSpending + RecentEraConway -> Conway.ConwaySpending + +mkMintingPurpose + :: forall era + . IsRecentEra era + => AsItem Word32 PolicyId + -> Alonzo.PlutusPurpose AsItem era +mkMintingPurpose = case recentEra @era of + RecentEraBabbage -> Alonzo.AlonzoMinting + RecentEraConway -> Conway.ConwayMinting + +mkRewardingPurpose + :: forall era + . IsRecentEra era + => AsItem Word32 RewardAccount + -> Alonzo.PlutusPurpose AsItem era +mkRewardingPurpose = case recentEra @era of + RecentEraBabbage -> Alonzo.AlonzoRewarding + RecentEraConway -> Conway.ConwayRewarding -------------------------------------------------------------------------------- -- Utils diff --git a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs index 82542298008..ac1698ace10 100644 --- a/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs +++ b/lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs @@ -30,6 +30,9 @@ module Internal.Cardano.Write.Tx.BalanceSpec import Prelude +import Cardano.Api.Ledger + ( EpochInterval (..) + ) import Cardano.Binary ( ToCBOR , serialize' @@ -40,7 +43,7 @@ import Cardano.Crypto.Wallet , toXPub ) import Cardano.Ledger.Alonzo.Plutus.TxInfo - ( TranslationError (..) + ( AlonzoContextError (..) ) import Cardano.Ledger.Api ( AllegraEraTxBody (..) @@ -64,12 +67,21 @@ import Cardano.Ledger.Api , serialiseAddr , totalCollateralTxBodyL ) +import Cardano.Ledger.Babbage.TxInfo + ( BabbageContextError (..) + ) +import Cardano.Ledger.Conway.TxInfo + ( ConwayContextError (..) + ) import Cardano.Ledger.Era ( Era ) import Cardano.Ledger.Keys.Bootstrap ( makeBootstrapWitness ) +import Cardano.Ledger.Plutus + ( mkCostModels + ) import Cardano.Ledger.Plutus.Language ( Language (..) ) @@ -706,8 +718,9 @@ spec_balanceTransaction = describe "balanceTransaction" $ do Left (ErrBalanceTxAssignRedeemers (ErrAssignRedeemersTranslationError + (AlonzoContextError (TimeTranslationPastHorizon - _pastHoriozon))) -> return () + _pastHoriozon)))) -> return () other -> expectationFailure $ "Expected pastHorizon failure; got " <> show other @@ -1466,15 +1479,26 @@ prop_balanceTransactionValid counterexample counterexampleText $ property False Left (ErrBalanceTxAssignRedeemers - (ErrAssignRedeemersTranslationError - (ByronTxOutInContext _))) -> - label "failed with ByronTxOutInContext" $ property True - Left - (ErrBalanceTxAssignRedeemers - (ErrAssignRedeemersTranslationError - (ReferenceScriptsNotSupported _))) -> - -- Possible with PlutusV1 - label "ReferenceScriptsNotSupported" $ property True + (ErrAssignRedeemersTranslationError x)) -> + case recentEra @era of + RecentEraBabbage -> case x of + ByronTxOutInContext _ -> + label "failed with ByronTxOutInContext" + $ property True + ReferenceScriptsNotSupported _ -> + label "ReferenceScriptsNotSupported" + $ property True + _ -> property False + RecentEraConway -> case x of + BabbageContextError y -> case y of + ByronTxOutInContext _ -> + label "failed with ByronTxOutInContext" + $ property True + ReferenceScriptsNotSupported _ -> + label "ReferenceScriptsNotSupported" + $ property True + _ -> property False + _ -> property False Left ErrBalanceTxUnableToCreateChange {} -> label "unable to create change" $ property True Left ErrBalanceTxInputResolutionConflicts{} -> @@ -1535,7 +1559,7 @@ prop_balanceTransactionValid tx partialTx.timelockKeyWitnessCounts) tx - let limit = protocolParams ^. ppMaxTxSizeL + let limit = intCast $ protocolParams ^. ppMaxTxSizeL let msg = unwords [ "The tx size " , show size @@ -2379,11 +2403,7 @@ costModelsForTesting = either (error . show) id $ do , 43357, 32, 32247, 32, 38314, 32, 20000000000, 20000000000, 9462713 , 1021, 10, 20000000000, 0, 20000000000 ] - pure Alonzo.CostModels - { costModelsValid = Map.fromList [(PlutusV1, v1), (PlutusV2, v2)] - , costModelsErrors = Map.empty - , costModelsUnknown = Map.empty - } + pure $ mkCostModels $ Map.fromList [(PlutusV1, v1), (PlutusV2, v2)] dummyChangeAddrGen :: ChangeAddressGen DummyChangeState dummyChangeAddrGen = ChangeAddressGen @@ -2495,7 +2515,7 @@ mockCardanoApiPParamsForBalancing = CardanoApi.ProtocolParameters CardanoApi.Lovelace 500_000_000 , CardanoApi.protocolParamMinPoolCost = CardanoApi.Lovelace 32_000_000 - , CardanoApi.protocolParamPoolRetireMaxEpoch = CardanoApi.EpochNo 2 + , CardanoApi.protocolParamPoolRetireMaxEpoch = EpochInterval 2 , CardanoApi.protocolParamStakePoolTargetNum = 100 , CardanoApi.protocolParamPoolPledgeInfluence = 0 , CardanoApi.protocolParamMonetaryExpansion = 0