diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d5dbdb8d1..6d3e3ee25 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -338,6 +338,7 @@ test-suite cardano-api-test tasty, tasty-hedgehog, tasty-quickcheck, + text, time, other-modules: diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index d559e51af..02f628257 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -12,6 +12,7 @@ module Cardano.Api.SerialiseLedgerCddl ( TextEnvelopeCddlError (..) , FromSomeTypeCDDL (..) + , cddlTypeToEra -- * Reading one of several transaction or @@ -315,26 +316,33 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = -- will make it easier to keep track of the different Cddl descriptions via -- a single sum data type. cddlTypeToEra :: Text -> Either TextEnvelopeCddlError AnyShelleyBasedEra -cddlTypeToEra = \case - "Witnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Witnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Witnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "Witnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Witnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Witnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway - "Unwitnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Unwitnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Unwitnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "Unwitnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Unwitnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Unwitnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway - "TxWitness ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "TxWitness AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "TxWitness MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "TxWitness AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "TxWitness BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "TxWitness ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway - unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType +cddlTypeToEra = + \case + "TxSignedShelley" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley + "Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary + "Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway + "Witnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley + "Witnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "Witnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary + "Witnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "Witnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "Witnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway + "Unwitnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley + "Unwitnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "Unwitnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary + "Unwitnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "Unwitnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "Unwitnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway + "TxWitness ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley + "TxWitness AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra + "TxWitness MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary + "TxWitness AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo + "TxWitness BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage + "TxWitness ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway + unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType readFileTextEnvelopeCddlAnyOf :: [FromSomeTypeCDDL TextEnvelope b] 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 3bf25a923..15356340d 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 @@ -10,9 +10,12 @@ module Test.Cardano.Api.CBOR where import Cardano.Api +import Cardano.Api.SerialiseLedgerCddl (cddlTypeToEra) +import Cardano.Api.SerialiseTextEnvelope (TextEnvelopeDescr (TextEnvelopeDescr)) import Cardano.Api.Shelley (AsType (..)) import Data.Proxy (Proxy (..)) +import qualified Data.Text as T import Test.Gen.Cardano.Api.Typed @@ -32,6 +35,22 @@ 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 + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- H.forAll $ makeSignedTransaction [] . fst <$> genValidTxBody era + shelleyBasedEraConstraints + era + ( H.tripping + x + (serialiseToTextEnvelope (Just (TextEnvelopeDescr "Ledger Cddl Format"))) + (deserialiseTxLedgerCddl era) + ) + prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] @@ -171,6 +190,30 @@ prop_roundtrip_UpdateProposal_CBOR = H.property $ do proposal <- H.forAll $ genUpdateProposal era H.trippingCbor AsUpdateProposal proposal +prop_Tx_cddlTypeToEra :: Property +prop_Tx_cddlTypeToEra = H.property $ do + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- forAll $ genTx era + shelleyBasedEraConstraints era $ do + let TextEnvelopeType d = textEnvelopeType (proxyToAsType (getProxy x)) + H.note_ $ "Envelope type: " <> show d + cddlTypeToEra (T.pack d) H.=== Right (AnyShelleyBasedEra era) + where + getProxy :: forall a. a -> Proxy a + getProxy _ = Proxy + +prop_TxWitness_cddlTypeToEra :: Property +prop_TxWitness_cddlTypeToEra = H.property $ do + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- forAll $ genCardanoKeyWitness era + shelleyBasedEraConstraints era $ do + let TextEnvelopeType d = textEnvelopeType (proxyToAsType (getProxy x)) + H.note_ $ "Envelope type: " <> show d + cddlTypeToEra (T.pack d) H.=== Right (AnyShelleyBasedEra era) + where + 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] @@ -264,10 +307,17 @@ tests = , testProperty "roundtrip script PlutusScriptV2 CBOR" prop_roundtrip_script_PlutusScriptV2_CBOR + , testProperty + "cddlTypeToEra for Tx types" + prop_Tx_cddlTypeToEra + , testProperty + "cddlTypeToEra for TxWitness types" + prop_TxWitness_cddlTypeToEra , testProperty "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