Merge pull request #5088 from IntersectMBO/td/move-upgrade-to-testlib

Move upgrade functions for tx, body, auxData and wits to `testlib`

Author: teodanciu

eras/allegra/impl/cardano-ledger-allegra.cabal

@@ -175,5 +175,4 @@ test-suite tests
     cardano-ledger-binary:testlib,
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-ledger-shelley:testlib,
-    data-default,
     testlib,

eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs

@@ -19,10 +19,8 @@ import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
 import Cardano.Ledger.Allegra.TxWits ()
 import Cardano.Ledger.Core (
   EraTx (..),
-  EraTxAuxData (upgradeTxAuxData),
   EraTxWits (..),
   NativeScript,
-  upgradeTxBody,
  )
 import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
 import Cardano.Ledger.Shelley.Tx (
@@ -61,12 +59,6 @@ instance EraTx AllegraEra where
 
   getMinFeeTx pp tx _ = shelleyMinFeeTx pp tx
 
-  upgradeTx (ShelleyTx txb txwits txAux) =
-    ShelleyTx
-      <$> upgradeTxBody txb
-      <*> pure (upgradeTxWits txwits)
-      <*> pure (fmap upgradeTxAuxData txAux)
-
 -- =======================================================
 -- Validating timelock scripts
 -- We extract ValidityInterval from TxBody with vldtTxBodyL getter

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxAuxData.hs

@@ -48,7 +48,7 @@ import Cardano.Ledger.MemoBytes (
   mkMemoizedEra,
  )
 import Cardano.Ledger.Shelley.Core
-import Cardano.Ledger.Shelley.TxAuxData (Metadatum, ShelleyTxAuxData (..), validMetadatum)
+import Cardano.Ledger.Shelley.TxAuxData (Metadatum, validMetadatum)
 import Codec.CBOR.Decoding (
   TokenType (
     TypeListLen,
@@ -92,8 +92,6 @@ instance EraTxAuxData AllegraEra where
 
   metadataTxAuxDataL = metadataAllegraTxAuxDataL
 
-  upgradeTxAuxData (ShelleyTxAuxData md) = AllegraTxAuxData md mempty
-
   validateTxAuxData _ (AllegraTxAuxData md as) = as `deepseq` all validMetadatum md
 
 metadataAllegraTxAuxDataL ::

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs

@@ -41,7 +41,7 @@ import Cardano.Ledger.Allegra.Era (AllegraEra)
 import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
 import Cardano.Ledger.Allegra.TxCert ()
 import Cardano.Ledger.Allegra.TxOut ()
-import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (SJust, SNothing))
+import Cardano.Ledger.BaseTypes (StrictMaybe (SJust, SNothing))
 import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR (..), ToCBOR)
 import Cardano.Ledger.Binary.Coders (
   Decode (..),
@@ -69,7 +69,7 @@ import Cardano.Ledger.MemoBytes (
   mkMemoizedEra,
  )
 import Cardano.Ledger.Shelley.Core
-import Cardano.Ledger.Shelley.PParams (Update (..), upgradeUpdate)
+import Cardano.Ledger.Shelley.PParams (Update (..))
 import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody)
 import Cardano.Ledger.TxIn (TxIn (..))
 import Control.DeepSeq (NFData (..))
@@ -328,23 +328,6 @@ instance EraTxBody AllegraEra where
 
   getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody
 
-  upgradeTxBody txBody = do
-    certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL)
-    pure $
-      AllegraTxBody
-        { atbInputs = txBody ^. inputsTxBodyL
-        , atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL)
-        , atbCerts = certs
-        , atbWithdrawals = txBody ^. withdrawalsTxBodyL
-        , atbTxFee = txBody ^. feeTxBodyL
-        , atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL)
-        , atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL)
-        , atbAuxDataHash = txBody ^. auxDataHashTxBodyL
-        }
-    where
-      ttlToValidityInterval :: SlotNo -> ValidityInterval
-      ttlToValidityInterval ttl = ValidityInterval SNothing (SJust ttl)
-
 instance ShelleyEraTxBody AllegraEra where
   ttlTxBodyL = notSupportedInThisEraL
   {-# INLINEABLE ttlTxBodyL #-}

eras/allegra/impl/src/Cardano/Ledger/Allegra/TxWits.hs

@@ -11,7 +11,7 @@ module Cardano.Ledger.Allegra.TxWits () where
 
 import Cardano.Ledger.Allegra.Era (AllegraEra)
 import Cardano.Ledger.Allegra.TxAuxData ()
-import Cardano.Ledger.Core (EraScript (upgradeScript), EraTxWits (..))
+import Cardano.Ledger.Core (EraTxWits (..))
 import Cardano.Ledger.Shelley.TxWits (
   ShelleyTxWits (..),
   addrShelleyTxWitsL,
@@ -32,9 +32,3 @@ instance EraTxWits AllegraEra where
 
   scriptTxWitsL = scriptShelleyTxWitsL
   {-# INLINE scriptTxWitsL #-}
-
-  upgradeTxWits stw =
-    ShelleyTxWits
-      (addrWits stw)
-      (upgradeScript <$> scriptWits stw)
-      (bootWits stw)

eras/allegra/impl/test/Test/Cardano/Ledger/Allegra/BinarySpec.hs

@@ -6,19 +6,16 @@
 module Test.Cardano.Ledger.Allegra.BinarySpec (spec) where
 
 import Cardano.Ledger.Allegra
-import Data.Default (def)
 import Test.Cardano.Ledger.Allegra.Arbitrary ()
 import Test.Cardano.Ledger.Allegra.Binary.Annotator ()
 import Test.Cardano.Ledger.Allegra.TreeDiff ()
 import Test.Cardano.Ledger.Common
-import Test.Cardano.Ledger.Core.Binary (specUpgrade)
 import Test.Cardano.Ledger.Core.Binary as Binary (decoderEquivalenceCoreEraTypesSpec, txSizeSpec)
 import Test.Cardano.Ledger.Core.Binary.RoundTrip (RuleListEra (..))
 import Test.Cardano.Ledger.Shelley.Binary.RoundTrip (roundTripShelleyCommonSpec)
 
 spec :: Spec
 spec = do
-  specUpgrade @AllegraEra def
   describe "RoundTrip" $ do
     roundTripShelleyCommonSpec @AllegraEra
   describe "DecCBOR instances equivalence" $ do

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs

@@ -81,7 +81,6 @@ import Cardano.Ledger.Alonzo.Scripts (
  )
 import Cardano.Ledger.Alonzo.TxBody (
   AlonzoEraTxBody (..),
-  AlonzoTxBodyUpgradeError,
   ScriptIntegrityHash,
   TxBody (AlonzoTxBody),
  )
@@ -112,10 +111,9 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.MemoBytes (EqRaw (..))
 import Cardano.Ledger.Plutus.Data (Data, hashData)
 import Cardano.Ledger.Plutus.Language (nonNativeLanguages)
-import Cardano.Ledger.Shelley.Tx (ShelleyTx (ShelleyTx), shelleyEqTxRaw)
+import Cardano.Ledger.Shelley.Tx (shelleyEqTxRaw)
 import qualified Cardano.Ledger.State as Shelley
 import Cardano.Ledger.Val (Val ((<+>), (<×>)))
-import Control.Arrow (left)
 import Control.DeepSeq (NFData (..))
 import Data.Aeson (ToJSON (..))
 import qualified Data.ByteString.Lazy as LBS
@@ -146,12 +144,8 @@ data AlonzoTx era = AlonzoTx
   }
   deriving (Generic)
 
-newtype AlonzoTxUpgradeError = ATUEBodyUpgradeError AlonzoTxBodyUpgradeError
-  deriving (Show)
-
 instance EraTx AlonzoEra where
   type Tx AlonzoEra = AlonzoTx AlonzoEra
-  type TxUpgradeError AlonzoEra = AlonzoTxUpgradeError
 
   mkBasicTx = mkBasicAlonzoTx
 
@@ -173,13 +167,6 @@ instance EraTx AlonzoEra where
   getMinFeeTx pp tx _ = alonzoMinFeeTx pp tx
   {-# INLINE getMinFeeTx #-}
 
-  upgradeTx (ShelleyTx body wits aux) =
-    AlonzoTx
-      <$> left ATUEBodyUpgradeError (upgradeTxBody body)
-      <*> pure (upgradeTxWits wits)
-      <*> pure (IsValid True)
-      <*> pure (fmap upgradeTxAuxData aux)
-
 instance (Tx era ~ AlonzoTx era, AlonzoEraTx era) => EqRaw (AlonzoTx era) where
   eqRaw = alonzoEqTxRaw
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs

@@ -38,7 +38,6 @@ module Cardano.Ledger.Alonzo.TxAuxData (
   hashAlonzoTxAuxData,
   validateAlonzoTxAuxData,
   getAlonzoTxAuxDataScripts,
-  translateAlonzoTxAuxData,
   metadataAlonzoTxAuxDataL,
   timelockScriptsAlonzoTxAuxDataL,
   plutusScriptsAllegraTxAuxDataL,
@@ -47,8 +46,8 @@ module Cardano.Ledger.Alonzo.TxAuxData (
   emptyAlonzoTxAuxDataRaw,
 ) where
 
-import Cardano.Ledger.Allegra.Scripts (Timelock, translateTimelock)
-import Cardano.Ledger.Allegra.TxAuxData (AllegraEraTxAuxData (..), AllegraTxAuxData (..))
+import Cardano.Ledger.Allegra.Scripts (Timelock)
+import Cardano.Ledger.Allegra.TxAuxData (AllegraEraTxAuxData (..))
 import Cardano.Ledger.Alonzo.Era
 import Cardano.Ledger.Alonzo.Scripts (
   AlonzoEraScript (..),
@@ -271,14 +270,6 @@ instance EraTxAuxData AlonzoEra where
 
   metadataTxAuxDataL = metadataAlonzoTxAuxDataL
 
-  upgradeTxAuxData (AllegraTxAuxData md scripts) =
-    mkMemoizedEra @AlonzoEra $
-      AlonzoTxAuxDataRaw
-        { atadrMetadata = md
-        , atadrTimelock = translateTimelock <$> scripts
-        , atadrPlutus = mempty
-        }
-
   validateTxAuxData = validateAlonzoTxAuxData
 
 metadataAlonzoTxAuxDataL ::
@@ -371,14 +362,3 @@ pattern AlonzoTxAuxData' ::
   AlonzoTxAuxData era
 pattern AlonzoTxAuxData' {atadMetadata', atadTimelock', atadPlutus'} <-
   (getMemoRawType -> AlonzoTxAuxDataRaw atadMetadata' atadTimelock' atadPlutus')
-
-translateAlonzoTxAuxData ::
-  (AlonzoEraScript era1, AlonzoEraScript era2) =>
-  AlonzoTxAuxData era1 ->
-  AlonzoTxAuxData era2
-translateAlonzoTxAuxData AlonzoTxAuxData {atadMetadata, atadTimelock, atadPlutus} =
-  AlonzoTxAuxData
-    { atadMetadata = atadMetadata
-    , atadTimelock = translateTimelock <$> atadTimelock
-    , atadPlutus = atadPlutus
-    }

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs

@@ -45,7 +45,6 @@ module Cardano.Ledger.Alonzo.TxBody (
     atbTxNetworkId
   ),
   AlonzoTxBodyRaw (..),
-  AlonzoTxBodyUpgradeError (..),
   AlonzoEraTxBody (..),
   ShelleyEraTxBody (..),
   AllegraEraTxBody (..),
@@ -103,11 +102,7 @@ import Cardano.Ledger.Binary (
  )
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Coin (Coin (..))
-import Cardano.Ledger.Mary (MaryEra)
 import Cardano.Ledger.Mary.Core
-import Cardano.Ledger.Mary.TxBody (
-  TxBody (..),
- )
 import Cardano.Ledger.Mary.Value (
   MultiAsset (..),
   PolicyID (..),
@@ -124,22 +119,17 @@ import Cardano.Ledger.MemoBytes (
   lensMemoRawType,
   mkMemoizedEra,
  )
-import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), Update (..))
+import Cardano.Ledger.Shelley.PParams (Update (..))
 import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody)
 import Cardano.Ledger.TxIn (TxIn (..))
-import Control.Arrow (left)
 import Control.DeepSeq (NFData (..))
-import Control.Monad (when)
-import Data.Default (def)
 import qualified Data.Map.Strict as Map
-import Data.Maybe.Strict (isSJust)
 import Data.OSet.Strict (OSet)
 import qualified Data.OSet.Strict as OSet
 import Data.Sequence.Strict (StrictSeq)
 import qualified Data.Sequence.Strict as StrictSeq
 import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Void (absurd)
 import Data.Word (Word32)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -200,18 +190,10 @@ deriving instance Show AlonzoTxBodyRaw
 instance Memoized (TxBody AlonzoEra) where
   type RawType (TxBody AlonzoEra) = AlonzoTxBodyRaw
 
-data AlonzoTxBodyUpgradeError
-  = -- | The TxBody contains a protocol parameter update that attempts to update
-    -- the min UTxO. Since this doesn't exist in Alonzo, we fail if an attempt is
-    -- made to update it.
-    ATBUEMinUTxOUpdated
-  deriving (Show)
-
 instance EraTxBody AlonzoEra where
   newtype TxBody AlonzoEra = MkAlonzoTxBody (MemoBytes AlonzoTxBodyRaw)
     deriving (ToCBOR, Generic)
     deriving newtype (SafeToHash)
-  type TxBodyUpgradeError AlonzoEra = AlonzoTxBodyUpgradeError
 
   mkBasicTxBody = mkMemoizedEra @AlonzoEra emptyAlonzoTxBodyRaw
 
@@ -254,60 +236,6 @@ instance EraTxBody AlonzoEra where
 
   getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody
 
-  upgradeTxBody
-    MaryTxBody
-      { mtbInputs
-      , mtbOutputs
-      , mtbCerts
-      , mtbWithdrawals
-      , mtbTxFee
-      , mtbValidityInterval
-      , mtbUpdate
-      , mtbAuxDataHash
-      , mtbMint
-      } = do
-      certs <-
-        traverse
-          (left absurd . upgradeTxCert)
-          mtbCerts
-
-      updates <- traverse upgradeUpdate mtbUpdate
-      pure $
-        AlonzoTxBody
-          { atbInputs = mtbInputs
-          , atbOutputs = upgradeTxOut <$> mtbOutputs
-          , atbCerts = certs
-          , atbWithdrawals = mtbWithdrawals
-          , atbTxFee = mtbTxFee
-          , atbValidityInterval = mtbValidityInterval
-          , atbUpdate = updates
-          , atbAuxDataHash = mtbAuxDataHash
-          , atbMint = mtbMint
-          , atbCollateral = mempty
-          , atbReqSignerHashes = mempty
-          , atbScriptIntegrityHash = SNothing
-          , atbTxNetworkId = SNothing
-          }
-      where
-        upgradeUpdate ::
-          Update MaryEra ->
-          Either AlonzoTxBodyUpgradeError (Update AlonzoEra)
-        upgradeUpdate (Update pp epoch) =
-          Update <$> upgradeProposedPPUpdates pp <*> pure epoch
-
-        upgradeProposedPPUpdates ::
-          ProposedPPUpdates MaryEra ->
-          Either AlonzoTxBodyUpgradeError (ProposedPPUpdates AlonzoEra)
-        upgradeProposedPPUpdates (ProposedPPUpdates m) =
-          ProposedPPUpdates
-            <$> traverse
-              ( \ppu -> do
-                  when (isSJust $ ppu ^. ppuMinUTxOValueL) $
-                    Left ATBUEMinUTxOUpdated
-                  pure $ upgradePParamsUpdate def ppu
-              )
-              m
-
 instance ShelleyEraTxBody AlonzoEra where
   ttlTxBodyL = notSupportedInThisEraL