Merge pull request #634 from IntersectMBO/fix-new-type-issues

Add new types to CDDL list and test forward compatibility of `deserialiseTxLedgerCddl`

cardano-api/cardano-api.cabal

@@ -338,6 +338,7 @@ test-suite cardano-api-test
     tasty,
     tasty-hedgehog,
     tasty-quickcheck,
+    text,
     time,
 
   other-modules:

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]

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