diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index f141620f6b..06353dac01 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -736,8 +736,6 @@ module Cardano.Api , deserialiseFromTextEnvelopeCddlAnyOf , writeTxFileTextEnvelopeCddl , writeTxWitnessFileTextEnvelopeCddl - , serialiseTxLedgerCddl - , deserialiseTxLedgerCddl , deserialiseByronTxCddl , serialiseWitnessLedgerCddl , deserialiseWitnessLedgerCddl diff --git a/cardano-api/src/Cardano/Api/Internal/SerialiseLedgerCddl.hs b/cardano-api/src/Cardano/Api/Internal/SerialiseLedgerCddl.hs index f491454ae9..6b187972e9 100644 --- a/cardano-api/src/Cardano/Api/Internal/SerialiseLedgerCddl.hs +++ b/cardano-api/src/Cardano/Api/Internal/SerialiseLedgerCddl.hs @@ -22,8 +22,6 @@ module Cardano.Api.Internal.SerialiseLedgerCddl , writeTxFileTextEnvelopeCddl , writeTxWitnessFileTextEnvelopeCddl -- Exported for testing - , serialiseTxLedgerCddl - , deserialiseTxLedgerCddl , deserialiseByronTxCddl , serialiseWitnessLedgerCddl , deserialiseWitnessLedgerCddl @@ -122,46 +120,6 @@ instance Error TextEnvelopeCddlError where TextEnvelopeCddlErrByronKeyWitnessUnsupported -> "TextEnvelopeCddl error: Byron key witnesses are currently unsupported." -{-# DEPRECATED - serialiseTxLedgerCddl - "Use 'serialiseToTextEnvelope' from 'Cardano.Api.Internal.SerialiseTextEnvelope' instead." - #-} -serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope -serialiseTxLedgerCddl era tx = - shelleyBasedEraConstraints era $ - (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx) - { teType = TextEnvelopeType $ T.unpack $ genType tx - } - where - genType :: Tx era -> Text - genType tx' = case getTxWitnesses tx' of - [] -> "Unwitnessed " <> genTxType - _ -> "Witnessed " <> genTxType - genTxType :: Text - genTxType = - case era of - ShelleyBasedEraShelley -> "Tx ShelleyEra" - ShelleyBasedEraAllegra -> "Tx AllegraEra" - ShelleyBasedEraMary -> "Tx MaryEra" - ShelleyBasedEraAlonzo -> "Tx AlonzoEra" - ShelleyBasedEraBabbage -> "Tx BabbageEra" - ShelleyBasedEraConway -> "Tx ConwayEra" - -{-# DEPRECATED - deserialiseTxLedgerCddl - "Use 'deserialiseFromTextEnvelope' from 'Cardano.Api.Internal.SerialiseTextEnvelope' instead." - #-} -deserialiseTxLedgerCddl - :: forall era - . ShelleyBasedEra era - -> TextEnvelope - -> Either TextEnvelopeError (Tx era) -deserialiseTxLedgerCddl era = - shelleyBasedEraConstraints era $ deserialiseFromTextEnvelope asType - where - asType :: AsType (Tx era) - asType = shelleyBasedEraConstraints era $ proxyToAsType Proxy - writeByronTxFileTextEnvelopeCddl :: File content Out -> Byron.ATxAux ByteString @@ -254,6 +212,11 @@ writeTxFileTextEnvelopeCddl era path tx = where txJson = encodePretty' textEnvelopeCddlJSONConfig (serialiseTxLedgerCddl era tx) <> "\n" + serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope + serialiseTxLedgerCddl era' tx' = + shelleyBasedEraConstraints era' $ + serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx' + writeTxWitnessFileTextEnvelopeCddl :: ShelleyBasedEra era -> File () Out @@ -312,6 +275,15 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = matching (FromCDDLTx ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl matching (FromCDDLWitness ttoken _f) = TextEnvelopeType (T.unpack ttoken) `legacyComparison` teType teCddl + deserialiseTxLedgerCddl + :: forall era + . ShelleyBasedEra era + -> TextEnvelope + -> Either TextEnvelopeError (Tx era) + deserialiseTxLedgerCddl era = + shelleyBasedEraConstraints era $ + deserialiseFromTextEnvelope (shelleyBasedEraConstraints era $ proxyToAsType Proxy) + -- Parse the text into types because this will increase code readability and -- will make it easier to keep track of the different Cddl descriptions via -- a single sum data type. diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs index 0af8d3144b..6a18cbe255 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs @@ -20,6 +20,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS import Data.Proxy (Proxy (..)) +import Data.Text (Text) import qualified Data.Text as T import Test.Gen.Cardano.Api.Hardcoded @@ -32,7 +33,6 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras as H import qualified Hedgehog.Gen as Gen import qualified Test.Hedgehog.Roundtrip.CBOR as H -import Test.Hedgehog.Roundtrip.CBOR import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -41,12 +41,43 @@ import Test.Tasty.Hedgehog (testProperty) -- TODO: Need to add PaymentExtendedKey roundtrip tests however -- we can't derive an Eq instance for Crypto.HD.XPrv --- This is the same test as prop_roundtrip_witness_CBOR but uses the --- new function `serialiseTxLedgerCddl` instead of the deprecated --- `serialiseToTextEnvelope`. `deserialiseTxLedgerCddl` must be --- compatible with both during the transition. -prop_forward_compatibility_txbody_CBOR :: Property -prop_forward_compatibility_txbody_CBOR = H.property $ do +prop_txbody_backwards_compatibility :: Property +prop_txbody_backwards_compatibility = H.property $ do + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- H.forAll $ makeSignedTransaction [] . fst <$> genValidTxBody era + shelleyBasedEraConstraints + era + ( H.tripping + x + (serialiseTxLedgerCddl era) + (deserialiseFromTextEnvelope (shelleyBasedEraConstraints era $ proxyToAsType Proxy)) + ) + where + -- This is the old implementation of serialisation for txbodies, and it is + -- now deprecated. But we keep it here for testing for backwards compatibility. + serialiseTxLedgerCddl :: ShelleyBasedEra era -> Tx era -> TextEnvelope + serialiseTxLedgerCddl era tx = + shelleyBasedEraConstraints era $ + (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format")) tx) + { teType = TextEnvelopeType $ T.unpack $ genType tx + } + where + genType :: Tx era -> Text + genType tx' = case getTxWitnesses tx' of + [] -> "Unwitnessed " <> genTxType + _ -> "Witnessed " <> genTxType + genTxType :: Text + genTxType = + case era of + ShelleyBasedEraShelley -> "Tx ShelleyEra" + ShelleyBasedEraAllegra -> "Tx AllegraEra" + ShelleyBasedEraMary -> "Tx MaryEra" + ShelleyBasedEraAlonzo -> "Tx AlonzoEra" + ShelleyBasedEraBabbage -> "Tx BabbageEra" + ShelleyBasedEraConway -> "Tx ConwayEra" + +prop_text_envelope_roundtrip_txbody_CBOR :: Property +prop_text_envelope_roundtrip_txbody_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ makeSignedTransaction [] . fst <$> genValidTxBody era shelleyBasedEraConstraints @@ -54,14 +85,20 @@ prop_forward_compatibility_txbody_CBOR = H.property $ do ( H.tripping x (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format"))) - (deserialiseTxLedgerCddl era) + (deserialiseFromTextEnvelope (shelleyBasedEraConstraints era $ proxyToAsType Proxy)) ) -prop_roundtrip_txbody_CBOR :: Property -prop_roundtrip_txbody_CBOR = H.property $ do +prop_text_envelope_roundtrip_tx_CBOR :: Property +prop_text_envelope_roundtrip_tx_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] - x <- H.forAll $ makeSignedTransaction [] . fst <$> genValidTxBody era - H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) + x <- H.forAll $ genTx era + shelleyBasedEraConstraints + era + ( H.tripping + x + (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format"))) + (deserialiseFromTextEnvelope (shelleyBasedEraConstraints era $ proxyToAsType Proxy)) + ) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do @@ -215,7 +252,7 @@ prop_roundtrip_non_double_encoded_always_succeeds_plutus_V3_CBOR = H.property $ prop_decode_only_double_wrapped_plutus_script_bytes_CBOR :: Property prop_decode_only_double_wrapped_plutus_script_bytes_CBOR = H.property $ do let alwaysSucceedsDoubleEncoded = Base16.decodeLenient "46450101002499" - decodeOnlyPlutusScriptBytes + H.decodeOnlyPlutusScriptBytes ShelleyBasedEraConway PlutusScriptV3 alwaysSucceedsDoubleEncoded @@ -224,7 +261,7 @@ prop_decode_only_double_wrapped_plutus_script_bytes_CBOR = H.property $ do prop_decode_only_wrapped_plutus_script_V1_CBOR :: Property prop_decode_only_wrapped_plutus_script_V1_CBOR = H.property $ do PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV1 - decodeOnlyPlutusScriptBytes + H.decodeOnlyPlutusScriptBytes ShelleyBasedEraConway PlutusScriptV1 (SBS.fromShort shortBs) @@ -233,7 +270,7 @@ prop_decode_only_wrapped_plutus_script_V1_CBOR = H.property $ do prop_decode_only_wrapped_plutus_script_V2_CBOR :: Property prop_decode_only_wrapped_plutus_script_V2_CBOR = H.property $ do PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV2 - decodeOnlyPlutusScriptBytes + H.decodeOnlyPlutusScriptBytes ShelleyBasedEraConway PlutusScriptV2 (SBS.fromShort shortBs) @@ -242,7 +279,7 @@ prop_decode_only_wrapped_plutus_script_V2_CBOR = H.property $ do prop_decode_only_wrapped_plutus_script_V3_CBOR :: Property prop_decode_only_wrapped_plutus_script_V3_CBOR = H.property $ do PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV3 - decodeOnlyPlutusScriptBytes + H.decodeOnlyPlutusScriptBytes ShelleyBasedEraConway PlutusScriptV3 (SBS.fromShort shortBs) @@ -289,12 +326,6 @@ prop_TxWitness_cddlTypeToEra = H.property $ do getProxy :: forall a. a -> Proxy a getProxy _ = Proxy -prop_roundtrip_Tx_Cddl :: Property -prop_roundtrip_Tx_Cddl = H.property $ do - AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] - x <- forAll $ genTx era - H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) - prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do AnyShelleyBasedEra sbe <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] @@ -303,11 +334,11 @@ prop_roundtrip_TxWitness_Cddl = H.property $ do prop_roundtrip_GovernancePoll_CBOR :: Property prop_roundtrip_GovernancePoll_CBOR = property $ do - trippingCbor AsGovernancePoll =<< forAll genGovernancePoll + H.trippingCbor AsGovernancePoll =<< forAll genGovernancePoll prop_roundtrip_GovernancePollAnswer_CBOR :: Property prop_roundtrip_GovernancePollAnswer_CBOR = property $ do - trippingCbor AsGovernancePollAnswer =<< forAll genGovernancePollAnswer + H.trippingCbor AsGovernancePollAnswer =<< forAll genGovernancePollAnswer -- ----------------------------------------------------------------------------- @@ -315,7 +346,10 @@ tests :: TestTree tests = testGroup "Test.Cardano.Api.Typed.CBOR" - [ testProperty "roundtrip witness CBOR" prop_roundtrip_witness_CBOR + [ testProperty "rountrip txbody text envelope" prop_text_envelope_roundtrip_txbody_CBOR + , testProperty "txbody backwards compatibility" prop_txbody_backwards_compatibility + , testProperty "rountrip tx text envelope" prop_text_envelope_roundtrip_tx_CBOR + , testProperty "roundtrip witness CBOR" prop_roundtrip_witness_CBOR , testProperty "roundtrip operational certificate CBOR" prop_roundtrip_operational_certificate_CBOR @@ -404,9 +438,6 @@ tests = "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR , testProperty "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR - , testProperty "roundtrip txbody forward compatibility CBOR" prop_forward_compatibility_txbody_CBOR - , testProperty "roundtrip txbody CBOR" prop_roundtrip_txbody_CBOR - , testProperty "roundtrip Tx Cddl" prop_roundtrip_Tx_Cddl , testProperty "roundtrip TxWitness Cddl" prop_roundtrip_TxWitness_Cddl , testProperty "roundtrip tx CBOR" prop_roundtrip_tx_CBOR , testProperty