Implement roundtrip tests for CDDL serialization

IntersectMBO · Jan 24, 2022 · 2a527e6 · 2a527e6
1 parent b504bda
commit 2a527e6
Show file tree

Hide file tree

Showing 4 changed files with 52 additions and 5 deletions.
diff --git a/cardano-api/gen/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Gen/Cardano/Api/Typed.hs
@@ -16,6 +16,7 @@ module Gen.Cardano.Api.Typed
   , genValueNestedRep
   , genValueNestedBundle
   , genByronKeyWitness
+  , genShelleyKeyWitness
 
   , genTxId
   , genTxIn

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -482,6 +482,10 @@ module Cardano.Api (
     readFileTextEnvelopeCddlAnyOf,
     writeTxFileTextEnvelopeCddl,
     writeTxWitnessFileTextEnvelopeCddl,
+    serialiseTxLedgerCddl,
+    deserialiseTxLedgerCddl,
+    serialiseWitnessLedgerCddl,
+    deserialiseWitnessLedgerCddl,
     TextEnvelopeCddlError(..),
 
     -- *** Reading one of several key types

diff --git a/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/src/Cardano/Api/SerialiseLedgerCddl.hs
@@ -18,6 +18,12 @@ module Cardano.Api.SerialiseLedgerCddl
 
   , writeTxFileTextEnvelopeCddl
   , writeTxWitnessFileTextEnvelopeCddl
+
+  -- Exported for testing
+  , serialiseTxLedgerCddl
+  , deserialiseTxLedgerCddl
+  , serialiseWitnessLedgerCddl
+  , deserialiseWitnessLedgerCddl
   )
   where
 
@@ -94,7 +100,7 @@ data TextEnvelopeCddlError
       Text   -- ^ Actual types
   | TextEnvelopeCddlErrUnknownType Text
   | TextEnvelopeCddlErrByronKeyWitnessUnsupported
-  deriving Show
+  deriving (Show, Eq)
 
 instance Error TextEnvelopeCddlError where
   displayError (TextEnvelopeCddlErrCBORDecodingError decoderError) =
@@ -190,11 +196,11 @@ deserialiseWitnessLedgerCddl
 deserialiseWitnessLedgerCddl era TextEnvelopeCddl{teCddlRawCBOR,teCddlDescription} =
   --TODO: Parse these into types
   case teCddlDescription of
-    "Key BootstrapWitness Shelley" -> do
+    "Key BootstrapWitness ShelleyEra" -> do
       w <- first TextEnvelopeCddlErrCBORDecodingError
              $ CBOR.decodeAnnotator "Shelley Witness" fromCBOR (LBS.fromStrict teCddlRawCBOR)
       Right $ ShelleyBootstrapWitness era w
-    "Key Witness Shelley" -> do
+    "Key Witness ShelleyEra" -> do
       w <- first TextEnvelopeCddlErrCBORDecodingError
              $ CBOR.decodeAnnotator"Shelley Witness" fromCBOR (LBS.fromStrict teCddlRawCBOR)
       Right $ ShelleyKeyWitness era w

diff --git a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs
@@ -1,4 +1,7 @@
+{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Test.Cardano.Api.Typed.CBOR
@@ -7,16 +10,16 @@ module Test.Cardano.Api.Typed.CBOR
 
 import           Cardano.Prelude
 
-import           Hedgehog (Property)
+import           Hedgehog (Property, forAll, property, success, tripping)
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.Hedgehog (testProperty)
 import           Test.Tasty.TH (testGroupGenerator)
 
 import           Cardano.Api
 
-import           Test.Cardano.Api.Typed.Orphans ()
 import           Gen.Cardano.Api.Typed
 import           Gen.Hedgehog.Roundtrip.CBOR (roundtrip_CBOR)
+import           Test.Cardano.Api.Typed.Orphans ()
 
 {- HLINT ignore "Use camelCase" -}
 
@@ -152,6 +155,39 @@ prop_roundtrip_UpdateProposal_CBOR :: Property
 prop_roundtrip_UpdateProposal_CBOR =
   roundtrip_CBOR AsUpdateProposal genUpdateProposal
 
+
+test_roundtrip_Tx_Cddl :: [TestTree]
+test_roundtrip_Tx_Cddl =
+  [ testProperty (show era) $ roundtrip_Tx_Cddl anyEra
+  | anyEra@(AnyCardanoEra era) <- [minBound..]
+  ]
+
+test_roundtrip_TxWitness_Cddl :: [TestTree]
+test_roundtrip_TxWitness_Cddl =
+  [ testProperty (show era) $ roundtrip_TxWitness_Cddl era
+  | AnyCardanoEra era <- [minBound..]
+  , AnyCardanoEra era /= AnyCardanoEra ByronEra
+  ]
+
+roundtrip_TxWitness_Cddl :: CardanoEra era -> Property
+roundtrip_TxWitness_Cddl era =
+  property $
+    case cardanoEraStyle era of
+      LegacyByronEra -> success
+      ShelleyBasedEra sbe -> do
+        keyWit <- forAll $ genShelleyKeyWitness era
+        tripping keyWit
+          (serialiseWitnessLedgerCddl sbe)
+          (deserialiseWitnessLedgerCddl sbe)
+
+roundtrip_Tx_Cddl :: AnyCardanoEra -> Property
+roundtrip_Tx_Cddl (AnyCardanoEra era) =
+  property $ do
+   tx <- forAll $ genTx era
+   tripping tx
+     serialiseTxLedgerCddl
+     (deserialiseTxLedgerCddl era)
+
 -- -----------------------------------------------------------------------------
 
 tests :: TestTree