From 053db1c37ab6e14b203970d35b1710db7dbfc291 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Wed, 14 Dec 2022 15:11:53 -0400 Subject: [PATCH] Create Cardano.Api.TxBodyInstances module Update HasTextEnvelope (Tx era) instance to be backwards compatible with `TextEnvelopeType`s introduced to distinguish between the CDDL format and the intermediate cli txbody format Update the SerialiseAsCBOR (KeyWitness era) instance to use the ledger's CDDL format Update checkTextEnvelopeFormat to accept `[TextEnvelopeType]` as we can now specify multiple `TextEnvelopeType`s in a given `HasTextEnvelope` instance --- cardano-api/cardano-api.cabal | 2 + cardano-api/src/Cardano/Api.hs | 1 + cardano-api/src/Cardano/Api/Tx.hs | 101 ++++---- cardano-api/src/Cardano/Api/TxBody.hs | 233 +---------------- .../src/Cardano/Api/TxBodyInstances.hs | 239 ++++++++++++++++++ cardano-cli/test/Test/OptParse.hs | 29 +-- cardano-cli/test/cardano-cli-test.hs | 4 +- 7 files changed, 313 insertions(+), 296 deletions(-) create mode 100644 cardano-api/src/Cardano/Api/TxBodyInstances.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 5bf9a00d4f4..c996c2615c8 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -96,6 +96,7 @@ library Cardano.Api.StakePoolMetadata Cardano.Api.Tx Cardano.Api.TxBody + Cardano.Api.TxBodyInstances Cardano.Api.TxIn Cardano.Api.TxMetadata Cardano.Api.Utils @@ -225,6 +226,7 @@ test-suite cardano-api-test , tasty , tasty-hedgehog , tasty-quickcheck + , text , time other-modules: Test.Cardano.Api.Crypto diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 8d5f55e1248..4365292bf83 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -763,6 +763,7 @@ import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.StakePoolMetadata import Cardano.Api.Tx import Cardano.Api.TxBody +import Cardano.Api.TxBodyInstances () import Cardano.Api.TxMetadata import Cardano.Api.Utils import Cardano.Api.Value diff --git a/cardano-api/src/Cardano/Api/Tx.hs b/cardano-api/src/Cardano/Api/Tx.hs index 1aadcd4430c..7d7c0e29b72 100644 --- a/cardano-api/src/Cardano/Api/Tx.hs +++ b/cardano-api/src/Cardano/Api/Tx.hs @@ -45,6 +45,9 @@ module Cardano.Api.Tx ( -- * Data family instances AsType(AsTx, AsByronTx, AsShelleyTx, AsMaryTx, AsAllegraTx, AsAlonzoTx, AsKeyWitness, AsByronWitness, AsShelleyWitness), + + -- * Serialisation + deserialiseShelleyBasedTx, ) where import Prelude @@ -66,7 +69,6 @@ import qualified Data.Vector as Vector -- import Cardano.Binary (Annotated (..)) import qualified Cardano.Binary as CBOR -import qualified Cardano.Prelude as CBOR (cborError) -- -- Crypto API used by consensus and Shelley (and should be used by Byron) @@ -95,8 +97,8 @@ import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.Keys.Bootstrap as Shelley import qualified Cardano.Ledger.SafeHash as Ledger -import qualified Cardano.Ledger.Shelley.Tx as Shelley import qualified Cardano.Ledger.Shelley.API as Ledger (ShelleyTx (..)) +import qualified Cardano.Ledger.Shelley.Tx as Shelley import Cardano.Ledger.Alonzo (AlonzoScript) import qualified Cardano.Ledger.Alonzo as Alonzo @@ -263,13 +265,20 @@ deserialiseShelleyBasedTx mkTx bs = instance IsCardanoEra era => HasTextEnvelope (Tx era) where textEnvelopeType _ = case cardanoEra :: CardanoEra era of - ByronEra -> "TxSignedByron" - ShelleyEra -> "TxSignedShelley" - AllegraEra -> "Tx AllegraEra" - MaryEra -> "Tx MaryEra" - AlonzoEra -> "Tx AlonzoEra" - BabbageEra -> "Tx BabbageEra" - + ByronEra -> + ["TxSignedByron", "Witnessed Tx ByronEra", "Unwitnessed Tx ByronEra"] + ShelleyEra -> + ["TxSignedShelley", "Witnessed Tx ShelleyEra", "Unwitnessed Tx ShelleyEra"] + AllegraEra -> + ["Tx AllegraEra", "Witnessed Tx AllegraEra", "Unwitnessed Tx AllegraEra"] + MaryEra -> + ["Tx MaryEra", "Witnessed Tx MaryEra", "Unwitnessed Tx MaryEra"] + AlonzoEra -> + ["Tx AlonzoEra", "Witnessed Tx AlonzoEra", "Unwitnessed Tx AlonzoEra"] + BabbageEra -> + ["Tx BabbageEra", "Witnessed Tx BabbageEra", "Unwitnessed Tx BabbageEra"] + + textEnvelopeDefaultDescr _ = "Ledger Cddl Format" data KeyWitness era where @@ -391,61 +400,45 @@ instance IsCardanoEra era => SerialiseAsCBOR (KeyWitness era) where serialiseToCBOR (ByronKeyWitness wit) = CBOR.serialize' wit serialiseToCBOR (ShelleyKeyWitness _era wit) = - CBOR.serializeEncoding' $ - encodeShelleyBasedKeyWitness wit + CBOR.serialize' wit serialiseToCBOR (ShelleyBootstrapWitness _era wit) = - CBOR.serializeEncoding' $ - encodeShelleyBasedBootstrapWitness wit + CBOR.serialize' wit deserialiseFromCBOR _ bs = case cardanoEra :: CardanoEra era of - ByronEra -> - ByronKeyWitness <$> CBOR.decodeFull' bs - - -- Use the same derialisation impl, but at different types: - ShelleyEra -> decodeShelleyBasedWitness ShelleyBasedEraShelley bs - AllegraEra -> decodeShelleyBasedWitness ShelleyBasedEraAllegra bs - MaryEra -> decodeShelleyBasedWitness ShelleyBasedEraMary bs - AlonzoEra -> decodeShelleyBasedWitness ShelleyBasedEraAlonzo bs - BabbageEra -> decodeShelleyBasedWitness ShelleyBasedEraBabbage bs - - -encodeShelleyBasedKeyWitness :: ToCBOR w => w -> CBOR.Encoding -encodeShelleyBasedKeyWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 0 <> toCBOR wit - -encodeShelleyBasedBootstrapWitness :: ToCBOR w => w -> CBOR.Encoding -encodeShelleyBasedBootstrapWitness wit = - CBOR.encodeListLen 2 <> CBOR.encodeWord 1 <> toCBOR wit - -decodeShelleyBasedWitness :: forall era. - ShelleyBasedEra era - -> ByteString - -> Either CBOR.DecoderError (KeyWitness era) -decodeShelleyBasedWitness era = - CBOR.decodeAnnotator "Shelley Witness" decode . LBS.fromStrict - where - decode :: CBOR.Decoder s (CBOR.Annotator (KeyWitness era)) - decode = do - CBOR.decodeListLenOf 2 - t <- CBOR.decodeWord - case t of - 0 -> fmap (fmap (ShelleyKeyWitness era)) fromCBOR - 1 -> fmap (fmap (ShelleyBootstrapWitness era)) fromCBOR - _ -> CBOR.cborError $ CBOR.DecoderErrorUnknownTag - "Shelley Witness" (fromIntegral t) + ByronEra -> ByronKeyWitness <$> CBOR.decodeFull' bs + ShelleyEra -> decodeKeyOrBootstrapWitness ShelleyBasedEraShelley bs + AllegraEra -> decodeKeyOrBootstrapWitness ShelleyBasedEraAllegra bs + MaryEra -> decodeKeyOrBootstrapWitness ShelleyBasedEraMary bs + AlonzoEra -> decodeKeyOrBootstrapWitness ShelleyBasedEraAlonzo bs + BabbageEra -> decodeKeyOrBootstrapWitness ShelleyBasedEraBabbage bs + +decodeKeyOrBootstrapWitness + :: ShelleyBasedEra era -> ByteString -> Either CBOR.DecoderError (KeyWitness era) +decodeKeyOrBootstrapWitness era bs = + case CBOR.decodeAnnotator "KeyWitness" fromCBOR (LBS.fromStrict bs) of + Right keyWit -> return $ ShelleyKeyWitness era keyWit + Left{} -> + ShelleyBootstrapWitness era + <$> CBOR.decodeAnnotator "BootstrapWitness" fromCBOR (LBS.fromStrict bs) instance IsCardanoEra era => HasTextEnvelope (KeyWitness era) where textEnvelopeType _ = case cardanoEra :: CardanoEra era of - ByronEra -> "TxWitnessByron" - ShelleyEra -> "TxWitness ShelleyEra" - AllegraEra -> "TxWitness AllegraEra" - MaryEra -> "TxWitness MaryEra" - AlonzoEra -> "TxWitness AlonzoEra" - BabbageEra -> "TxWitness BabbageEra" + ByronEra -> ["TxWitnessByron"] + ShelleyEra -> ["TxWitness ShelleyEra"] + AllegraEra -> ["TxWitness AllegraEra"] + MaryEra -> ["TxWitness MaryEra"] + AlonzoEra -> ["TxWitness AlonzoEra"] + BabbageEra -> ["TxWitness BabbageEra"] + + textEnvelopeDefaultDescr ByronKeyWitness{} = "" + textEnvelopeDefaultDescr ShelleyBootstrapWitness{} = + "Key BootstrapWitness ShelleyEra" + textEnvelopeDefaultDescr ShelleyKeyWitness{} = + "Key Witness ShelleyEra" pattern Tx :: TxBody era -> [KeyWitness era] -> Tx era pattern Tx txbody ws <- (getTxBodyAndWitnesses -> (txbody, ws)) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index cb693992d08..38223f0c3a1 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -168,7 +168,6 @@ import qualified Data.Aeson.Types as Aeson import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as LBS import Data.Foldable (for_, toList) import Data.Function (on) import Data.List (intercalate, sortBy) @@ -192,11 +191,9 @@ import qualified Text.Parsec as Parsec import Text.Parsec (()) import qualified Text.Parsec.String as Parsec -import Cardano.Binary (Annotated (..), reAnnotate, recoverBytes) -import qualified Cardano.Binary as CBOR +import Cardano.Binary (Annotated (..), reAnnotate) import qualified Cardano.Crypto.Hash.Class as Crypto -import qualified Cardano.Ledger.Serialization as CBOR (Sized, decodeNullMaybe, encodeNullMaybe, - mkSized, sizedValue) +import qualified Cardano.Ledger.Serialization as CBOR (Sized, mkSized, sizedValue) import Cardano.Slotting.Slot (SlotNo (..)) import qualified Cardano.Chain.Common as Byron @@ -205,19 +202,19 @@ import qualified Cardano.Crypto.Hashing as Byron import qualified Cardano.Ledger.Address as Shelley import qualified Cardano.Ledger.AuxiliaryData as Ledger +import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..), + BabbageTxBody (BabbageTxBody), BabbageTxOut (BabbageTxOut)) import Cardano.Ledger.BaseTypes (StrictMaybe (..), maybeToStrictMaybe) +import qualified Cardano.Ledger.Block as Ledger import qualified Cardano.Ledger.Coin as Ledger +import Cardano.Ledger.Core (EraAuxiliaryData) import qualified Cardano.Ledger.Core as Core import qualified Cardano.Ledger.Core as Ledger import qualified Cardano.Ledger.Credential as Shelley import Cardano.Ledger.Crypto (StandardCrypto) +import qualified Cardano.Ledger.Era as CC import qualified Cardano.Ledger.Keys as Shelley import qualified Cardano.Ledger.SafeHash as SafeHash -import Cardano.Ledger.Babbage.TxBody (BabbageEraTxBody (..), - BabbageTxBody (BabbageTxBody), BabbageTxOut (BabbageTxOut)) -import qualified Cardano.Ledger.Block as Ledger -import Cardano.Ledger.Core (EraAuxiliaryData) -import qualified Cardano.Ledger.Era as CC import qualified Cardano.Ledger.TxIn as Ledger import Cardano.Ledger.Val (isZero) @@ -228,23 +225,23 @@ import qualified Cardano.Ledger.Shelley.Metadata as Shelley import qualified Cardano.Ledger.Shelley.Tx as Shelley import qualified Cardano.Ledger.Shelley.TxBody as Shelley -import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra +import Cardano.Ledger.Mary.Value (MaryValue) import Cardano.Ledger.ShelleyMA.AuxiliaryData (MAAuxiliaryData (..)) +import qualified Cardano.Ledger.ShelleyMA.AuxiliaryData as Allegra +import Cardano.Ledger.ShelleyMA.TxBody (MATxBody (..)) import qualified Cardano.Ledger.ShelleyMA.TxBody as Allegra import qualified Cardano.Ledger.ShelleyMA.TxBody as Mary -import Cardano.Ledger.ShelleyMA.TxBody (MATxBody (..)) -import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (AlonzoAuxiliaryData)) +import qualified Cardano.Ledger.Alonzo.Data as Alonzo import qualified Cardano.Ledger.Alonzo.Language as Alonzo import qualified Cardano.Ledger.Alonzo.PParams 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.TxWitness as Alonzo -import Cardano.Ledger.Alonzo.Data (AlonzoAuxiliaryData (AlonzoAuxiliaryData)) -import qualified Cardano.Ledger.Alonzo.Data as Alonzo import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (AlonzoTxBody), AlonzoTxOut (AlonzoTxOut)) +import qualified Cardano.Ledger.Alonzo.TxBody as Alonzo +import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo import qualified Cardano.Ledger.Babbage.PParams as Babbage import qualified Cardano.Ledger.Babbage.TxBody as Babbage @@ -268,7 +265,6 @@ import Cardano.Api.ScriptData import Cardano.Api.SerialiseCBOR import Cardano.Api.SerialiseJSON import Cardano.Api.SerialiseRaw -import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.TxIn import Cardano.Api.TxMetadata import Cardano.Api.Utils @@ -1773,207 +1769,6 @@ pattern AsMaryTxBody :: AsType (TxBody MaryEra) pattern AsMaryTxBody = AsTxBody AsMaryEra {-# COMPLETE AsMaryTxBody #-} -instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where - - serialiseToCBOR (ByronTxBody txbody) = - recoverBytes txbody - - serialiseToCBOR (ShelleyTxBody era txbody txscripts redeemers txmetadata scriptValidity) = - case era of - -- Use the same serialisation impl, but at different types: - ShelleyBasedEraShelley -> serialiseShelleyBasedTxBody - era txbody txscripts redeemers txmetadata scriptValidity - ShelleyBasedEraAllegra -> serialiseShelleyBasedTxBody - era txbody txscripts redeemers txmetadata scriptValidity - ShelleyBasedEraMary -> serialiseShelleyBasedTxBody - era txbody txscripts redeemers txmetadata scriptValidity - ShelleyBasedEraAlonzo -> serialiseShelleyBasedTxBody - era txbody txscripts redeemers txmetadata scriptValidity - - ShelleyBasedEraBabbage -> serialiseShelleyBasedTxBody - era txbody txscripts redeemers txmetadata scriptValidity - deserialiseFromCBOR _ bs = - case cardanoEra :: CardanoEra era of - ByronEra -> - ByronTxBody <$> - CBOR.decodeFullAnnotatedBytes - "Byron TxBody" - CBOR.fromCBORAnnotated - (LBS.fromStrict bs) - - -- Use the same derialisation impl, but at different types: - ShelleyEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraShelley bs - AllegraEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraAllegra bs - MaryEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraMary bs - AlonzoEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraAlonzo bs - BabbageEra -> deserialiseShelleyBasedTxBody ShelleyBasedEraBabbage bs - --- | The serialisation format for the different Shelley-based eras are not the --- same, but they can be handled generally with one overloaded implementation. -serialiseShelleyBasedTxBody - :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => ToCBOR (Ledger.TxBody ledgerera) - => ToCBOR (Ledger.Script ledgerera) - => ToCBOR (Alonzo.TxDats ledgerera) - => ToCBOR (Alonzo.Redeemers ledgerera) - => ToCBOR (Ledger.AuxiliaryData ledgerera) - => ShelleyBasedEra era - -> Ledger.TxBody ledgerera - -> [Ledger.Script ledgerera] - -> TxBodyScriptData era - -> Maybe (Ledger.AuxiliaryData ledgerera) - -> TxScriptValidity era -- ^ Mark script as expected to pass or fail validation - -> ByteString -serialiseShelleyBasedTxBody era txbody txscripts - TxBodyNoScriptData txmetadata scriptValidity = - -- Backwards compat for pre-Alonzo era tx body files - case era of - ShelleyBasedEraShelley -> preAlonzo - ShelleyBasedEraAllegra -> preAlonzo - ShelleyBasedEraMary -> preAlonzo - ShelleyBasedEraAlonzo -> - CBOR.serializeEncoding' - $ CBOR.encodeListLen 4 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata - ShelleyBasedEraBabbage -> - CBOR.serializeEncoding' - $ CBOR.encodeListLen 4 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata - where - preAlonzo = CBOR.serializeEncoding' - $ CBOR.encodeListLen 3 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata - -serialiseShelleyBasedTxBody _era txbody txscripts - (TxBodyScriptData _ datums redeemers) - txmetadata txBodycriptValidity = - CBOR.serializeEncoding' $ - CBOR.encodeListLen 6 - <> CBOR.toCBOR txbody - <> CBOR.toCBOR txscripts - <> CBOR.toCBOR datums - <> CBOR.toCBOR redeemers - <> CBOR.toCBOR (txScriptValidityToScriptValidity txBodycriptValidity) - <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata - -deserialiseShelleyBasedTxBody - :: forall era ledgerera. - ShelleyLedgerEra era ~ ledgerera - => FromCBOR (CBOR.Annotator (Ledger.TxBody ledgerera)) - => FromCBOR (CBOR.Annotator (Ledger.Script ledgerera)) - => FromCBOR (CBOR.Annotator (Alonzo.TxDats ledgerera)) - => FromCBOR (CBOR.Annotator (Alonzo.Redeemers ledgerera)) - => FromCBOR (CBOR.Annotator (Ledger.AuxiliaryData ledgerera)) - => ShelleyBasedEra era - -> ByteString - -> Either CBOR.DecoderError (TxBody era) -deserialiseShelleyBasedTxBody era bs = - CBOR.decodeAnnotator - "Shelley TxBody" - decodeAnnotatedTuple - (LBS.fromStrict bs) - where - decodeAnnotatedTuple :: CBOR.Decoder s (CBOR.Annotator (TxBody era)) - decodeAnnotatedTuple = do - len <- CBOR.decodeListLen - - case len of - -- Backwards compat for pre-Alonzo era tx body files - 2 -> do - txbody <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR - return $ CBOR.Annotator $ \fbs -> - ShelleyTxBody era - (flip CBOR.runAnnotator fbs txbody) - [] -- scripts - (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) - (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) - 3 -> do - txbody <- fromCBOR - txscripts <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR - return $ CBOR.Annotator $ \fbs -> - ShelleyTxBody era - (flip CBOR.runAnnotator fbs txbody) - (map (flip CBOR.runAnnotator fbs) txscripts) - (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) - (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) - 4 -> do - sValiditySupported <- - case txScriptValiditySupportedInShelleyBasedEra era of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ - \script validity flag but got: " - <> show era - Just supported -> return supported - - txbody <- fromCBOR - txscripts <- fromCBOR - scriptValidity <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR - return $ CBOR.Annotator $ \fbs -> - ShelleyTxBody era - (flip CBOR.runAnnotator fbs txbody) - (map (flip CBOR.runAnnotator fbs) txscripts) - (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) - (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) - 6 -> do - sDataSupported <- - case scriptDataSupportedInEra (shelleyBasedToCardanoEra era) of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports script\ - \ data but got: " - <> show era - Just supported -> return supported - - sValiditySupported <- - case txScriptValiditySupportedInShelleyBasedEra era of - Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ - \script validity flag but got: " - <> show era - Just supported -> return supported - - txbody <- fromCBOR - txscripts <- fromCBOR - datums <- fromCBOR - redeemers <- fromCBOR - scriptValidity <- fromCBOR - txmetadata <- CBOR.decodeNullMaybe fromCBOR - - let txscriptdata = CBOR.Annotator $ \fbs -> - TxBodyScriptData sDataSupported - (flip CBOR.runAnnotator fbs datums) - (flip CBOR.runAnnotator fbs redeemers) - - return $ CBOR.Annotator $ \fbs -> - ShelleyTxBody era - (flip CBOR.runAnnotator fbs txbody) - (map (flip CBOR.runAnnotator fbs) txscripts) - (flip CBOR.runAnnotator fbs txscriptdata) - (fmap (flip CBOR.runAnnotator fbs) txmetadata) - (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) - _ -> fail $ "expected tx body tuple of size 2, 3, 4 or 6, got " <> show len - -instance IsCardanoEra era => HasTextEnvelope (TxBody era) where - textEnvelopeType _ = - case cardanoEra :: CardanoEra era of - ByronEra -> "TxUnsignedByron" - ShelleyEra -> "TxUnsignedShelley" - AllegraEra -> "TxBodyAllegra" - MaryEra -> "TxBodyMary" - AlonzoEra -> "TxBodyAlonzo" - BabbageEra -> "TxBodyBabbage" - -- | Calculate the transaction identifier for a 'TxBody'. -- getTxId :: forall era. TxBody era -> TxId diff --git a/cardano-api/src/Cardano/Api/TxBodyInstances.hs b/cardano-api/src/Cardano/Api/TxBodyInstances.hs new file mode 100644 index 00000000000..e1753695497 --- /dev/null +++ b/cardano-api/src/Cardano/Api/TxBodyInstances.hs @@ -0,0 +1,239 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +{- HLINT ignore "Avoid lambda using `infix`" -} +{- HLINT ignore "Redundant flip" -} +{- HLINT ignore "Use section" -} + +-- | Transaction bodies +-- +module Cardano.Api.TxBodyInstances + ( serialiseShelleyBasedTxBody + , deserialiseShelleyBasedTxBody + ) where + +import Prelude + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Typeable (Typeable) + +import qualified Cardano.Binary as CBOR +import qualified Cardano.Ledger.Alonzo.TxWitness as Alonzo +import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Serialization as CBOR + +import Cardano.Api.Eras +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api.Tx +import Cardano.Api.TxBody + +instance IsCardanoEra era => HasTextEnvelope (TxBody era) where + textEnvelopeType _ = + case cardanoEra :: CardanoEra era of + ByronEra -> ["TxUnsignedByron", "Unwitnessed Tx ByronEra"] + ShelleyEra -> ["TxUnsignedShelley", "Unwitnessed Tx ShelleyEra"] + AllegraEra -> ["TxBodyAllegra", "Unwitnessed Tx AllegraEra"] + MaryEra -> ["TxBodyMary", "Unwitnessed Tx MaryEra"] + AlonzoEra -> ["TxBodyAlonzo", "Unwitnessed Tx AlonzoEra"] + BabbageEra -> ["TxBodyBabbage", "Unwitnessed Tx BabbageEra"] + textEnvelopeDefaultDescr _ = "Ledger Cddl Format" + +instance IsCardanoEra era => SerialiseAsCBOR (TxBody era) where + + serialiseToCBOR (ByronTxBody txbody) = + CBOR.recoverBytes txbody + + serialiseToCBOR txbody = + let tx = makeSignedTransaction [] txbody + in serialiseToCBOR tx + + deserialiseFromCBOR _ bs = + case cardanoEra :: CardanoEra era of + ByronEra -> + ByronTxBody <$> + CBOR.decodeFullAnnotatedBytes + "Byron TxBody" + CBOR.fromCBORAnnotated + (LBS.fromStrict bs) + + -- Use the same derialisation impl, but at different types: + ShelleyEra -> do + tx <- deserialiseShelleyBasedTx (ShelleyTx ShelleyBasedEraShelley) bs + let (txBody, _) = getTxBodyAndWitnesses tx + return txBody + AllegraEra -> do + tx <- deserialiseShelleyBasedTx (ShelleyTx ShelleyBasedEraAllegra) bs + let (txBody, _) = getTxBodyAndWitnesses tx + return txBody + MaryEra -> do + tx <- deserialiseShelleyBasedTx (ShelleyTx ShelleyBasedEraMary) bs + let (txBody, _) = getTxBodyAndWitnesses tx + return txBody + AlonzoEra -> do + tx <- deserialiseShelleyBasedTx (ShelleyTx ShelleyBasedEraAlonzo) bs + let (txBody, _) = getTxBodyAndWitnesses tx + return txBody + BabbageEra -> do + tx <- deserialiseShelleyBasedTx (ShelleyTx ShelleyBasedEraBabbage) bs + let (txBody, _) = getTxBodyAndWitnesses tx + return txBody + +-- | The serialisation format for the different Shelley-based eras are not the +-- same, but they can be handled generally with one overloaded implementation. +serialiseShelleyBasedTxBody + :: ToCBOR (Ledger.TxBody (ShelleyLedgerEra era)) + => ToCBOR (Ledger.Script (ShelleyLedgerEra era)) + => ToCBOR (Ledger.AuxiliaryData (ShelleyLedgerEra era)) + => Typeable (ShelleyLedgerEra era) + => ShelleyBasedEra era + -> TxBody era + -> BS.ByteString +serialiseShelleyBasedTxBody _ (ShelleyTxBody era txbody txscripts + TxBodyNoScriptData txmetadata scriptValidity) = + -- Backwards compat for pre-Alonzo era tx body files + case era of + ShelleyBasedEraShelley -> preAlonzo + ShelleyBasedEraAllegra -> preAlonzo + ShelleyBasedEraMary -> preAlonzo + ShelleyBasedEraAlonzo -> + CBOR.serializeEncoding' + $ CBOR.encodeListLen 4 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + ShelleyBasedEraBabbage -> + CBOR.serializeEncoding' + $ CBOR.encodeListLen 4 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.toCBOR (txScriptValidityToScriptValidity scriptValidity) + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + where + preAlonzo = CBOR.serializeEncoding' + $ CBOR.encodeListLen 3 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + +serialiseShelleyBasedTxBody _ (ShelleyTxBody _era txbody txscripts + (TxBodyScriptData _ datums redeemers) + txmetadata txBodycriptValidity) = + CBOR.serializeEncoding' $ + CBOR.encodeListLen 6 + <> CBOR.toCBOR txbody + <> CBOR.toCBOR txscripts + <> CBOR.toCBOR datums + <> CBOR.toCBOR redeemers + <> CBOR.toCBOR (txScriptValidityToScriptValidity txBodycriptValidity) + <> CBOR.encodeNullMaybe CBOR.toCBOR txmetadata + +deserialiseShelleyBasedTxBody + :: forall era ledgerera. + ShelleyLedgerEra era ~ ledgerera + => FromCBOR (CBOR.Annotator (Ledger.TxBody ledgerera)) + => FromCBOR (CBOR.Annotator (Ledger.Script ledgerera)) + => FromCBOR (CBOR.Annotator (Alonzo.TxDats ledgerera)) + => FromCBOR (CBOR.Annotator (Alonzo.Redeemers ledgerera)) + => FromCBOR (CBOR.Annotator (Ledger.AuxiliaryData ledgerera)) + => ShelleyBasedEra era + -> BS.ByteString + -> Either CBOR.DecoderError (TxBody era) +deserialiseShelleyBasedTxBody era bs = + CBOR.decodeAnnotator + "Shelley TxBody" + decodeAnnotatedTuple + (LBS.fromStrict bs) + where + decodeAnnotatedTuple :: CBOR.Decoder s (CBOR.Annotator (TxBody era)) + decodeAnnotatedTuple = do + len <- CBOR.decodeListLen + + case len of + -- Backwards compat for pre-Alonzo era tx body files + 2 -> do + txbody <- fromCBOR + txmetadata <- CBOR.decodeNullMaybe fromCBOR + return $ CBOR.Annotator $ \fbs -> + ShelleyTxBody era + (flip CBOR.runAnnotator fbs txbody) + [] -- scripts + (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) + (fmap (flip CBOR.runAnnotator fbs) txmetadata) + (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) + 3 -> do + txbody <- fromCBOR + txscripts <- fromCBOR + txmetadata <- CBOR.decodeNullMaybe fromCBOR + return $ CBOR.Annotator $ \fbs -> + ShelleyTxBody era + (flip CBOR.runAnnotator fbs txbody) + (map (flip CBOR.runAnnotator fbs) txscripts) + (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) + (fmap (flip CBOR.runAnnotator fbs) txmetadata) + (flip CBOR.runAnnotator fbs (return TxScriptValidityNone)) + 4 -> do + sValiditySupported <- + case txScriptValiditySupportedInShelleyBasedEra era of + Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ + \script validity flag but got: " + <> show era + Just supported -> return supported + + txbody <- fromCBOR + txscripts <- fromCBOR + scriptValidity <- fromCBOR + txmetadata <- CBOR.decodeNullMaybe fromCBOR + return $ CBOR.Annotator $ \fbs -> + ShelleyTxBody era + (flip CBOR.runAnnotator fbs txbody) + (map (flip CBOR.runAnnotator fbs) txscripts) + (flip CBOR.runAnnotator fbs (return TxBodyNoScriptData)) + (fmap (flip CBOR.runAnnotator fbs) txmetadata) + (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) + 6 -> do + sDataSupported <- + case scriptDataSupportedInEra (shelleyBasedToCardanoEra era) of + Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports script\ + \ data but got: " + <> show era + Just supported -> return supported + + sValiditySupported <- + case txScriptValiditySupportedInShelleyBasedEra era of + Nothing -> fail $ "deserialiseShelleyBasedTxBody: Expected an era that supports the \ + \script validity flag but got: " + <> show era + Just supported -> return supported + + txbody <- fromCBOR + txscripts <- fromCBOR + datums <- fromCBOR + redeemers <- fromCBOR + scriptValidity <- fromCBOR + txmetadata <- CBOR.decodeNullMaybe fromCBOR + + let txscriptdata = CBOR.Annotator $ \fbs -> + TxBodyScriptData sDataSupported + (flip CBOR.runAnnotator fbs datums) + (flip CBOR.runAnnotator fbs redeemers) + + return $ CBOR.Annotator $ \fbs -> + ShelleyTxBody era + (flip CBOR.runAnnotator fbs txbody) + (map (flip CBOR.runAnnotator fbs) txscripts) + (flip CBOR.runAnnotator fbs txscriptdata) + (fmap (flip CBOR.runAnnotator fbs) txmetadata) + (flip CBOR.runAnnotator fbs (return $ TxScriptValidity sValiditySupported scriptValidity)) + _ -> fail $ "expected tx body tuple of size 2, 3, 4 or 6, got " <> show len diff --git a/cardano-cli/test/Test/OptParse.hs b/cardano-cli/test/Test/OptParse.hs index 4a875e1e59b..c3a3b67ca0a 100644 --- a/cardano-cli/test/Test/OptParse.hs +++ b/cardano-cli/test/Test/OptParse.hs @@ -1,6 +1,5 @@ module Test.OptParse - ( checkTxCddlFormat - , checkTextEnvelopeFormat + ( checkTextEnvelopeFormat , equivalence , execCardanoCLI , propertyOnce @@ -18,8 +17,6 @@ import qualified GHC.Stack as GHC import Cardano.Api -import Cardano.CLI.Shelley.Run.Read - import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Process as H import Hedgehog.Internal.Property (Diff, MonadTest, liftTest, mkTest) @@ -42,15 +39,15 @@ execCardanoCLI = GHC.withFrozenCallStack $ H.execFlex "cardano-cli" "CARDANO_CLI -- | Checks that the 'tvType' and 'tvDescription' are equivalent between two files. checkTextEnvelopeFormat :: (MonadTest m, MonadIO m, HasCallStack) - => TextEnvelopeType + => [TextEnvelopeType] -> FilePath -> FilePath -> m () -checkTextEnvelopeFormat tve reference created = do - eRefTextEnvelope <- liftIO $ readTextEnvelopeOfTypeFromFile tve reference +checkTextEnvelopeFormat tvTypes reference created = do + eRefTextEnvelope <- liftIO $ readTextEnvelopeOfTypeFromFile tvTypes reference refTextEnvelope <- handleTextEnvelope eRefTextEnvelope - eCreatedTextEnvelope <- liftIO $ readTextEnvelopeOfTypeFromFile tve created + eCreatedTextEnvelope <- liftIO $ readTextEnvelopeOfTypeFromFile tvTypes created createdTextEnvelope <- handleTextEnvelope eCreatedTextEnvelope typeTitleEquivalence refTextEnvelope createdTextEnvelope @@ -64,20 +61,12 @@ checkTextEnvelopeFormat tve reference created = do typeTitleEquivalence :: MonadTest m => TextEnvelope -> TextEnvelope -> m () typeTitleEquivalence (TextEnvelope refType refTitle _) (TextEnvelope createdType createdTitle _) = do - equivalence refType createdType + if any (== refType) tvTypes && + any (== createdType) tvTypes + then return () + else equivalence refType createdType equivalence refTitle createdTitle -checkTxCddlFormat - :: (MonadTest m, MonadIO m, HasCallStack) - => FilePath -- ^ Reference/golden file - -> FilePath -- ^ Newly created file - -> m () -checkTxCddlFormat reference created = do - r <- liftIO $ readCddlTx reference - c <- liftIO $ readCddlTx created - r H.=== c - - -------------------------------------------------------------------------------- -- Helpers, Error rendering & Clean up -------------------------------------------------------------------------------- diff --git a/cardano-cli/test/cardano-cli-test.hs b/cardano-cli/test/cardano-cli-test.hs index bd8e9156d4a..e7ef43780f4 100644 --- a/cardano-cli/test/cardano-cli-test.hs +++ b/cardano-cli/test/cardano-cli-test.hs @@ -2,7 +2,6 @@ import Cardano.Prelude import Hedgehog.Main (defaultMain) -import qualified Test.Cli.CliIntermediateFormat import qualified Test.Cli.FilePermissions import qualified Test.Cli.ITN import qualified Test.Cli.JSON @@ -17,8 +16,7 @@ import qualified Test.Config.Mainnet main :: IO () main = defaultMain - [ Test.Cli.CliIntermediateFormat.tests - , Test.Cli.FilePermissions.tests + [ Test.Cli.FilePermissions.tests , Test.Cli.ITN.tests , Test.Cli.JSON.tests , Test.Cli.MultiAssetParsing.tests