diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 217a3f6595..de1e791c05 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -310,6 +310,7 @@ library gen Test.Gen.Cardano.Api.Metadata Test.Gen.Cardano.Api.Orphans Test.Gen.Cardano.Api.ProtocolParameters + Test.Gen.Cardano.Api.TxOut Test.Gen.Cardano.Api.Typed Test.Gen.Cardano.Crypto.Seed Test.Hedgehog.Golden.ErrorMessage @@ -420,6 +421,11 @@ test-suite cardano-api-test Test.Cardano.Api.Transaction.Autobalance Test.Cardano.Api.Transaction.Body.Plutus.Scripts Test.Cardano.Api.TxBody + Test.Cardano.Api.TxOut.Helpers + Test.Cardano.Api.TxOut.Json + Test.Cardano.Api.TxOut.JsonEdgeCases + Test.Cardano.Api.TxOut.JsonErrorCases + Test.Cardano.Api.TxOut.JsonRoundtrip Test.Cardano.Api.Value ghc-options: diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/TxOut.hs b/cardano-api/gen/Test/Gen/Cardano/Api/TxOut.hs new file mode 100644 index 0000000000..d50235dbdd --- /dev/null +++ b/cardano-api/gen/Test/Gen/Cardano/Api/TxOut.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Additional generators for TxOut JSON testing +module Test.Gen.Cardano.Api.TxOut + ( -- * Specific Datum Type Generators + genTxOutWithNoDatum + , genTxOutWithDatumHash + , genTxOutWithSupplementalDatum + , genTxOutWithInlineDatum + + -- * Invalid JSON Generators + , genConflictingDatumJSON + , genMismatchedInlineDatumHashJSON + , genPartialInlineDatumJSON + ) +where + +import Cardano.Api hiding (Value) + +import Data.Aeson (Value (..), object, (.=)) + +import Test.Gen.Cardano.Api.Typed + +import Hedgehog (Gen) +import Hedgehog.Gen qualified as Gen + +-- | Generate a TxOut with no datum and no reference script +genTxOutWithNoDatum + :: ShelleyBasedEra era + -> Gen (TxOut CtxTx era) +genTxOutWithNoDatum era = + TxOut + <$> genAddressInEra era + <*> genTxOutValue era + <*> pure TxOutDatumNone + <*> pure ReferenceScriptNone + +-- | Generate a TxOut with a datum hash (Alonzo+) +genTxOutWithDatumHash + :: forall era + . AlonzoEraOnwards era + -> Gen (TxOut CtxTx era) +genTxOutWithDatumHash w = + alonzoEraOnwardsConstraints w $ + TxOut + <$> genAddressInEra sbe + <*> genTxOutValue sbe + <*> (TxOutDatumHash w <$> genHashScriptData) + <*> genReferenceScript sbe + where + sbe :: ShelleyBasedEra era + sbe = convert w + +-- | Generate a TxOut with a supplemental datum (Alonzo+, CtxTx only) +genTxOutWithSupplementalDatum + :: forall era + . AlonzoEraOnwards era + -> Gen (TxOut CtxTx era) +genTxOutWithSupplementalDatum w = + alonzoEraOnwardsConstraints w $ + TxOut + <$> genAddressInEra sbe + <*> genTxOutValue sbe + <*> (TxOutSupplementalDatum w <$> genHashableScriptData) + <*> genReferenceScript sbe + where + sbe :: ShelleyBasedEra era + sbe = convert w + +-- | Generate a TxOut with an inline datum (Babbage+) +genTxOutWithInlineDatum + :: forall era + . BabbageEraOnwards era + -> Gen (TxOut CtxTx era) +genTxOutWithInlineDatum w = + babbageEraOnwardsConstraints w $ + TxOut + <$> genAddressInEra sbe + <*> genTxOutValue sbe + <*> (TxOutDatumInline w <$> genHashableScriptData) + <*> genReferenceScript sbe + where + sbe :: ShelleyBasedEra era + sbe = convert w + +-- | Generate JSON with conflicting Alonzo and Babbage datum fields +-- +-- Note: Uses Conway era for address/value generation because ToJSON +-- for TxOut requires Exp.IsEra constraint (Conway+). +genConflictingDatumJSON :: Gen Value +genConflictingDatumJSON = do + addr <- genAddressInEra ShelleyBasedEraConway + val <- genTxOutValue ShelleyBasedEraConway + datum1 <- genHashableScriptData + datum2 <- genHashableScriptData + let hash1 = hashScriptDataBytes datum1 + let hash2 = hashScriptDataBytes datum2 + pure $ + object + [ "address" .= addr + , "value" .= val + , "datumhash" .= hash1 + , "datum" .= scriptDataToJson ScriptDataJsonDetailedSchema datum1 + , "inlineDatumhash" .= hash2 + , "inlineDatum" .= scriptDataToJson ScriptDataJsonDetailedSchema datum2 + ] + +-- | Generate JSON with inline datum that doesn't match its hash +genMismatchedInlineDatumHashJSON :: Gen Value +genMismatchedInlineDatumHashJSON = do + addr <- genAddressInEra ShelleyBasedEraConway + val <- genTxOutValue ShelleyBasedEraConway + datum <- genHashableScriptData + wrongDatum <- Gen.filter (/= datum) genHashableScriptData + let wrongHash = hashScriptDataBytes wrongDatum + pure $ + object + [ "address" .= addr + , "value" .= val + , "inlineDatumhash" .= wrongHash + , "inlineDatum" .= scriptDataToJson ScriptDataJsonDetailedSchema datum + ] + +-- | Generate JSON with only partial inline datum fields +genPartialInlineDatumJSON :: Gen Value +genPartialInlineDatumJSON = do + addr <- genAddressInEra ShelleyBasedEraConway + val <- genTxOutValue ShelleyBasedEraConway + datum <- genHashableScriptData + let hash = hashScriptDataBytes datum + Gen.choice + [ -- Only hash, no datum + pure $ + object + [ "address" .= addr + , "value" .= val + , "inlineDatumhash" .= hash + ] + , -- Only datum, no hash + pure $ + object + [ "address" .= addr + , "value" .= val + , "inlineDatum" .= scriptDataToJson ScriptDataJsonDetailedSchema datum + ] + ] diff --git a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs index 996bac75b1..647955620e 100644 --- a/cardano-api/src/Cardano/Api/Era/Internal/Case.hs +++ b/cardano-api/src/Cardano/Api/Era/Internal/Case.hs @@ -3,6 +3,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +-- | Era case functions for branching on era types +-- +-- DEPRECATION NOTICE: The @case*@ functions in this module are deprecated and will be +-- removed in a future release. They were used for era-based conditional logic but are +-- being phased out in favor of direct pattern matching or other approaches. +-- +-- DO NOT add new @case*@ functions to this module. If you need era-based branching, +-- prefer direct pattern matching on era witnesses or use the conversion functions +-- provided by the era system. module Cardano.Api.Era.Internal.Case ( -- Case on CardanoEra caseByronOrShelleyBasedEra diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Helpers.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Helpers.hs new file mode 100644 index 0000000000..7f9895b1d5 --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Helpers.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Test helpers and assertion utilities for TxOut JSON testing +module Test.Cardano.Api.TxOut.Helpers + ( -- * JSON Field Assertions + assertHasFields + , assertFieldPresent + , assertFieldNull + , assertAllNull + , assertFieldEquals + + -- * Parse Failure Assertions + , assertParseFails + , assertParseFailsWithMessage + + -- * Datum Assertions + , assertDatumEqual + , assertDatumHashMatches + + -- * JSON Object Manipulation + , getObjectField + , hasField + , isNullField + ) +where + +import Cardano.Api hiding (Value) + +import Control.Monad (unless) +import Data.Aeson (Object, Value (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Aeson.Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Stack (HasCallStack, callStack) + +import Hedgehog.Extras qualified as H +import Hedgehog.Internal.Property (MonadTest) + +-- | Assert that a JSON value has all specified fields +assertHasFields :: (MonadTest m, HasCallStack) => Value -> [Text] -> m () +assertHasFields (Object obj) fields = do + let missing = filter (not . hasField obj) fields + unless (null missing) $ + H.failMessage callStack $ + "Missing fields: " <> show missing <> "\nObject: " <> show obj +assertHasFields val _ = + H.failMessage callStack $ "Expected Object but got: " <> show val + +-- | Assert that a field is present with a specific value +assertFieldPresent :: (MonadTest m, HasCallStack) => Value -> Text -> Value -> m () +assertFieldPresent (Object obj) field expected = do + case getObjectField obj field of + Nothing -> + H.failMessage callStack $ "Field '" <> Text.unpack field <> "' not found in object" + Just actual -> + unless (actual == expected) $ + H.failMessage callStack $ + "Field '" + <> Text.unpack field + <> "' has wrong value.\nExpected: " + <> show expected + <> "\nActual: " + <> show actual +assertFieldPresent val field _ = + H.failMessage callStack $ + "Expected Object but got: " <> show val <> " when checking field " <> Text.unpack field + +-- | Assert that a field equals a specific value (same as assertFieldPresent) +assertFieldEquals :: (MonadTest m, HasCallStack) => Value -> Text -> Value -> m () +assertFieldEquals = assertFieldPresent + +-- | Assert that a field is present and is null +assertFieldNull :: (MonadTest m, HasCallStack) => Value -> Text -> m () +assertFieldNull (Object obj) field = do + case getObjectField obj field of + Nothing -> + H.failMessage callStack $ "Field '" <> Text.unpack field <> "' not found in object" + Just Null -> return () + Just val -> + H.failMessage callStack $ + "Field '" <> Text.unpack field <> "' is not null, got: " <> show val +assertFieldNull val field = + H.failMessage callStack $ + "Expected Object but got: " <> show val <> " when checking field " <> Text.unpack field + +-- | Assert that all specified fields are null +assertAllNull :: (MonadTest m, HasCallStack) => Value -> [Text] -> m () +assertAllNull obj fields = mapM_ (assertFieldNull obj) fields + +-- | Assert that parsing a JSON value fails +assertParseFails :: forall a m. (Aeson.FromJSON a, MonadTest m, HasCallStack) => Value -> m () +assertParseFails val = + case Aeson.fromJSON val of + Aeson.Success (_ :: a) -> + H.failMessage callStack $ "Expected parse failure but succeeded for: " <> show val + Aeson.Error _ -> return () + +-- | Assert that parsing fails with a message containing the specified text +assertParseFailsWithMessage + :: forall a m. (Aeson.FromJSON a, MonadTest m, HasCallStack) => Value -> Text -> m () +assertParseFailsWithMessage val expectedMsg = + case Aeson.fromJSON val of + Aeson.Success (_ :: a) -> + H.failMessage callStack $ "Expected parse failure but succeeded for: " <> show val + Aeson.Error msg -> + unless (expectedMsg `Text.isInfixOf` Text.pack msg) $ + H.failMessage callStack $ + "Error message doesn't contain expected text.\n" + <> "Expected substring: " + <> Text.unpack expectedMsg + <> "\nActual message: " + <> msg + +-- | Assert that two datums are equal +assertDatumEqual + :: (MonadTest m, HasCallStack) + => TxOutDatum ctx era + -> TxOutDatum ctx era + -> m () +assertDatumEqual d1 d2 = + unless (d1 == d2) $ + H.failMessage callStack $ + "Datums not equal.\nExpected: " <> show d1 <> "\nActual: " <> show d2 + +-- | Assert that a datum's hash matches the expected hash +assertDatumHashMatches + :: (MonadTest m, HasCallStack) + => HashableScriptData + -> Hash ScriptData + -> m () +assertDatumHashMatches datum expectedHash = + let actualHash = hashScriptDataBytes datum + in unless (actualHash == expectedHash) $ + H.failMessage callStack $ + "Datum hash mismatch.\n" + <> "Expected: " + <> show expectedHash + <> "\nActual: " + <> show actualHash + +-- | Get a field from a JSON object +getObjectField :: Object -> Text -> Maybe Value +getObjectField obj field = KeyMap.lookup (Aeson.Key.fromText field) obj + +-- | Check if an object has a field +hasField :: Object -> Text -> Bool +hasField obj field = KeyMap.member (Aeson.Key.fromText field) obj + +-- | Check if a field is null +isNullField :: Object -> Text -> Bool +isNullField obj field = + case getObjectField obj field of + Just Null -> True + _ -> False diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Json.hs new file mode 100644 index 0000000000..99b3f0541d --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/Json.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Comprehensive JSON tests for TxOut instances +-- +-- This module provides extensive testing coverage for the ToJSON and FromJSON +-- instances of TxOut across all eras and contexts. +-- +-- Test coverage includes: +-- - Roundtrip tests for all eras (Byron through Dijkstra) +-- - Both CtxTx and CtxUTxO contexts +-- - All datum types (None, Hash, Supplemental, Inline) +-- - Error cases (conflicting fields, mismatched hashes, etc.) +-- - Edge cases (null handling, supplemental datum ambiguity) +-- - ToJSON output validation +module Test.Cardano.Api.TxOut.Json + ( tests + ) +where + +import Test.Cardano.Api.TxOut.JsonEdgeCases qualified as EdgeCases +import Test.Cardano.Api.TxOut.JsonErrorCases qualified as ErrorCases +import Test.Cardano.Api.TxOut.JsonRoundtrip qualified as Roundtrip + +import Test.Tasty (TestTree, testGroup) + +-- | All TxOut JSON tests +tests :: TestTree +tests = + testGroup + "TxOut.Json" + [ Roundtrip.tests + , ErrorCases.tests + , EdgeCases.tests + ] diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonEdgeCases.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonEdgeCases.hs new file mode 100644 index 0000000000..470d13cbe5 --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonEdgeCases.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Edge case tests for TxOut JSON instances +-- +-- Note: Tests that require ToJSON use Conway era due to Exp.IsEra constraint. +-- Tests that only need FromJSON can use any ShelleyBasedEra. +module Test.Cardano.Api.TxOut.JsonEdgeCases + ( tests + ) +where + +import Cardano.Api hiding (Value) + +import Data.Aeson (Value (..), eitherDecode, encode, object, (.=)) + +import Test.Gen.Cardano.Api.TxOut +import Test.Gen.Cardano.Api.Typed + +import Test.Cardano.Api.TxOut.Helpers + +import Hedgehog (Property, forAll) +import Hedgehog qualified as H +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) + +-- | All edge case tests +tests :: TestTree +tests = + testGroup + "JsonEdgeCases" + [ testGroup "Supplemental Datum Behavior" testsSupplementalDatum + , testGroup "Null Field Handling" testsNullFields + , testGroup "ToJSON Output Validation" testsToJSONValidation + ] + +-- ----------------------------------------------------------------------------- +-- Supplemental Datum Tests +-- ----------------------------------------------------------------------------- + +testsSupplementalDatum :: [TestTree] +testsSupplementalDatum = + [ testPropertyNamed + "supplemental datum produces both datumhash and datum fields" + "prop_supplemental_datum_produces_both_fields" + prop_supplemental_datum_produces_both_fields + , testPropertyNamed + "supplemental datum roundtrips to supplemental (not hash)" + "prop_supplemental_datum_roundtrips_to_supplemental" + prop_supplemental_datum_roundtrips_to_supplemental + ] + +prop_supplemental_datum_produces_both_fields :: Property +prop_supplemental_datum_produces_both_fields = H.property $ do + txOut <- forAll $ genTxOutWithSupplementalDatum AlonzoEraOnwardsConway + let json = toJSON txOut + assertHasFields json ["datumhash", "datum"] + -- Verify datumhash is not null + case json of + Object obj -> do + case getObjectField obj "datumhash" of + Just Null -> do + H.annotate "datumhash should not be null for supplemental datum" + H.failure + Just _ -> return () + Nothing -> do + H.annotate "datumhash field missing" + H.failure + case getObjectField obj "datum" of + Just Null -> do + H.annotate "datum should not be null for supplemental datum" + H.failure + Just _ -> return () + Nothing -> do + H.annotate "datum field missing" + H.failure + _ -> do + H.annotate "Expected JSON object" + H.failure + +prop_supplemental_datum_roundtrips_to_supplemental :: Property +prop_supplemental_datum_roundtrips_to_supplemental = H.property $ do + txOut@(TxOut _ _ datum _) <- forAll $ genTxOutWithSupplementalDatum AlonzoEraOnwardsConway + case datum of + TxOutSupplementalDatum{} -> do + let decoded = eitherDecode @(TxOut CtxTx ConwayEra) (encode txOut) + case decoded of + Right (TxOut _ _ decodedDatum _) -> + case decodedDatum of + TxOutSupplementalDatum{} -> H.success + _ -> do + H.annotate $ "Expected TxOutSupplementalDatum but got: " <> show decodedDatum + H.failure + Left err -> do + H.annotate $ "Decode failed: " <> err + H.failure + _ -> do + H.annotate "Expected TxOutSupplementalDatum" + H.failure + +-- ----------------------------------------------------------------------------- +-- Null Field Handling Tests +-- ----------------------------------------------------------------------------- + +testsNullFields :: [TestTree] +testsNullFields = + [ testPropertyNamed + "null fields optional for parsing" + "prop_null_fields_optional" + prop_null_fields_optional + , testPropertyNamed + "explicit null fields accepted" + "prop_explicit_null_fields_accepted" + prop_explicit_null_fields_accepted + ] + +prop_null_fields_optional :: Property +prop_null_fields_optional = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + val <- forAll $ genTxOutValue ShelleyBasedEraConway + let json = object ["address" .= addr, "value" .= val] + case eitherDecode @(TxOut CtxTx ConwayEra) (encode json) of + Right (TxOut _ _ datum _) -> + assertDatumEqual datum TxOutDatumNone + Left err -> do + H.annotate $ "Parse failed: " <> err + H.failure + +prop_explicit_null_fields_accepted :: Property +prop_explicit_null_fields_accepted = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + val <- forAll $ genTxOutValue ShelleyBasedEraConway + let json = + object + [ "address" .= addr + , "value" .= val + , "datumhash" .= Null + , "datum" .= Null + , "inlineDatum" .= Null + , "referenceScript" .= Null + ] + case eitherDecode @(TxOut CtxTx ConwayEra) (encode json) of + Right (TxOut _ _ datum refScript) -> do + assertDatumEqual datum TxOutDatumNone + case refScript of + ReferenceScriptNone -> H.success + _ -> do + H.annotate $ "Expected ReferenceScriptNone but got: " <> show refScript + H.failure + Left err -> do + H.annotate $ "Parse failed: " <> err + H.failure + +-- ----------------------------------------------------------------------------- +-- ToJSON Output Validation Tests +-- ----------------------------------------------------------------------------- + +testsToJSONValidation :: [TestTree] +testsToJSONValidation = + [ testPropertyNamed + "no datum has null fields (Conway)" + "prop_toJSON_no_datum_has_null_fields" + prop_toJSON_no_datum_has_null_fields + , testPropertyNamed + "inline datum uses inline fields" + "prop_toJSON_inline_datum_uses_inline_fields" + prop_toJSON_inline_datum_uses_inline_fields + ] + +prop_toJSON_no_datum_has_null_fields :: Property +prop_toJSON_no_datum_has_null_fields = H.property $ do + txOut <- forAll $ genTxOutWithNoDatum ShelleyBasedEraConway + let json = toJSON txOut + assertHasFields json ["datumhash", "datum", "inlineDatum", "inlineDatumRaw", "referenceScript"] + assertAllNull json ["datumhash", "datum", "inlineDatum", "inlineDatumRaw", "referenceScript"] + +prop_toJSON_inline_datum_uses_inline_fields :: Property +prop_toJSON_inline_datum_uses_inline_fields = H.property $ do + txOut <- forAll $ genTxOutWithInlineDatum BabbageEraOnwardsConway + let json = toJSON txOut + -- Should have inlineDatumhash and inlineDatum + assertHasFields json ["inlineDatumhash", "inlineDatum"] + case json of + Object obj -> do + -- inlineDatumhash and inlineDatum should not be null + case getObjectField obj "inlineDatumhash" of + Just Null -> do + H.annotate "inlineDatumhash should not be null for inline datum" + H.failure + Just _ -> return () + Nothing -> do + H.annotate "inlineDatumhash field missing" + H.failure + case getObjectField obj "inlineDatum" of + Just Null -> do + H.annotate "inlineDatum should not be null for inline datum" + H.failure + Just _ -> return () + Nothing -> do + H.annotate "inlineDatum field missing" + H.failure + -- datum field should be null (datumhash doesn't exist for inline datums) + assertFieldNull json "datum" + _ -> do + H.annotate "Expected JSON object" + H.failure diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonErrorCases.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonErrorCases.hs new file mode 100644 index 0000000000..440cad9b02 --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonErrorCases.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Error case tests for TxOut JSON parsing +-- +-- Note: These tests only use FromJSON (parsing), so they can test any +-- ShelleyBasedEra. ToJSON is not required for error case validation. +module Test.Cardano.Api.TxOut.JsonErrorCases + ( tests + ) +where + +import Cardano.Api hiding (Value) + +import Data.Aeson (object, (.=)) + +import Test.Gen.Cardano.Api.TxOut +import Test.Gen.Cardano.Api.Typed + +import Test.Cardano.Api.TxOut.Helpers + +import Hedgehog (Property, forAll) +import Hedgehog qualified as H +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) + +-- | All error case tests +tests :: TestTree +tests = + testGroup + "JsonErrorCases" + [ testGroup "Conflicting Datums" testsConflictingDatums + , testGroup "Mismatched Hashes" testsMismatchedHashes + , testGroup "Partial Fields" testsPartialFields + , testGroup "Invalid Data" testsInvalidData + , testGroup "Missing Required Fields" testsMissingFields + ] + +-- ----------------------------------------------------------------------------- +-- Conflicting Datum Tests +-- ----------------------------------------------------------------------------- + +-- Note: Dijkstra era tests are commented out as shelleyBasedEraConstraints +-- doesn't yet fully support Dijkstra. +testsConflictingDatums :: [TestTree] +testsConflictingDatums = + [ testPropertyNamed + "Conway: reject conflicting Alonzo and Conway datums" + "prop_reject_conflicting_datums_conway" + prop_reject_conflicting_datums_conway + ] + +prop_reject_conflicting_datums_conway :: Property +prop_reject_conflicting_datums_conway = H.property $ do + json <- forAll genConflictingDatumJSON + assertParseFailsWithMessage @(TxOut CtxTx ConwayEra) json "Alonzo era datum and a Conway era datum" + +-- ----------------------------------------------------------------------------- +-- Mismatched Hash Tests +-- ----------------------------------------------------------------------------- + +testsMismatchedHashes :: [TestTree] +testsMismatchedHashes = + [ testPropertyNamed + "Conway CtxTx: reject mismatched inline datum hash" + "prop_reject_mismatched_hash_conway_ctx_tx" + prop_reject_mismatched_hash_conway_ctx_tx + , testPropertyNamed + "Conway CtxUTxO: reject mismatched inline datum hash" + "prop_reject_mismatched_hash_conway_ctx_utxo" + prop_reject_mismatched_hash_conway_ctx_utxo + ] + +prop_reject_mismatched_hash_conway_ctx_tx :: Property +prop_reject_mismatched_hash_conway_ctx_tx = H.property $ do + json <- forAll genMismatchedInlineDatumHashJSON + assertParseFailsWithMessage @(TxOut CtxTx ConwayEra) + json + "Inline datum not equivalent to inline datum hash" + +prop_reject_mismatched_hash_conway_ctx_utxo :: Property +prop_reject_mismatched_hash_conway_ctx_utxo = H.property $ do + json <- forAll genMismatchedInlineDatumHashJSON + assertParseFailsWithMessage @(TxOut CtxUTxO ConwayEra) + json + "Inline datum not equivalent to inline datum hash" + +-- ----------------------------------------------------------------------------- +-- Partial Field Tests +-- ----------------------------------------------------------------------------- + +testsPartialFields :: [TestTree] +testsPartialFields = + [ testPropertyNamed + "Conway CtxTx: reject partial inline datum fields" + "prop_reject_partial_inline_datum_conway_ctx_tx" + prop_reject_partial_inline_datum_conway_ctx_tx + , testPropertyNamed + "Conway CtxUTxO: reject partial inline datum fields" + "prop_reject_partial_inline_datum_conway_ctx_utxo" + prop_reject_partial_inline_datum_conway_ctx_utxo + ] + +prop_reject_partial_inline_datum_conway_ctx_tx :: Property +prop_reject_partial_inline_datum_conway_ctx_tx = H.property $ do + json <- forAll genPartialInlineDatumJSON + assertParseFailsWithMessage @(TxOut CtxTx ConwayEra) + json + "either an inline datum hash or an inline datum" + +prop_reject_partial_inline_datum_conway_ctx_utxo :: Property +prop_reject_partial_inline_datum_conway_ctx_utxo = H.property $ do + json <- forAll genPartialInlineDatumJSON + assertParseFailsWithMessage @(TxOut CtxUTxO ConwayEra) + json + "either an inline datum hash or an inline datum" + +-- ----------------------------------------------------------------------------- +-- Invalid Data Tests +-- ----------------------------------------------------------------------------- + +testsInvalidData :: [TestTree] +testsInvalidData = + [ testPropertyNamed + "Conway: reject datum without hash" + "prop_reject_datum_without_hash" + prop_reject_datum_without_hash + , testPropertyNamed + "Conway: reject invalid script data in datum" + "prop_reject_invalid_script_data_datum" + prop_reject_invalid_script_data_datum + , testPropertyNamed + "Conway: reject invalid script data in inline datum" + "prop_reject_invalid_script_data_inline_datum" + prop_reject_invalid_script_data_inline_datum + ] + +prop_reject_datum_without_hash :: Property +prop_reject_datum_without_hash = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + val <- forAll $ genTxOutValue ShelleyBasedEraConway + let json = + object + [ "address" .= addr + , "value" .= val + , "datum" .= object ["int" .= (42 :: Int)] + ] + assertParseFailsWithMessage @(TxOut CtxTx ConwayEra) json "Only datum JSON was found" + +prop_reject_invalid_script_data_datum :: Property +prop_reject_invalid_script_data_datum = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + val <- forAll $ genTxOutValue ShelleyBasedEraConway + scriptDataHash <- forAll genHashScriptData + let json = + object + [ "address" .= addr + , "value" .= val + , "datumhash" .= scriptDataHash + , "datum" .= object ["invalid" .= ("structure" :: String)] + ] + assertParseFails @(TxOut CtxTx ConwayEra) json + +prop_reject_invalid_script_data_inline_datum :: Property +prop_reject_invalid_script_data_inline_datum = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + val <- forAll $ genTxOutValue ShelleyBasedEraConway + scriptDataHash <- forAll genHashScriptData + let json = + object + [ "address" .= addr + , "value" .= val + , "inlineDatumhash" .= scriptDataHash + , "inlineDatum" .= object ["invalid" .= ("structure" :: String)] + ] + assertParseFails @(TxOut CtxTx ConwayEra) json + +-- ----------------------------------------------------------------------------- +-- Missing Required Fields Tests +-- ----------------------------------------------------------------------------- + +testsMissingFields :: [TestTree] +testsMissingFields = + [ testPropertyNamed "reject missing address" "prop_reject_missing_address" prop_reject_missing_address + , testPropertyNamed "reject missing value" "prop_reject_missing_value" prop_reject_missing_value + ] + +prop_reject_missing_address :: Property +prop_reject_missing_address = H.property $ do + val <- forAll $ genTxOutValue ShelleyBasedEraConway + let json = object ["value" .= val] + assertParseFails @(TxOut CtxTx ConwayEra) json + +prop_reject_missing_value :: Property +prop_reject_missing_value = H.property $ do + addr <- forAll $ genAddressInEra ShelleyBasedEraConway + let json = object ["address" .= addr] + assertParseFails @(TxOut CtxTx ConwayEra) json diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonRoundtrip.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonRoundtrip.hs new file mode 100644 index 0000000000..fbdd2bb8b1 --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/TxOut/JsonRoundtrip.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Comprehensive roundtrip tests for TxOut JSON instances +-- +-- Note: These tests only cover Conway and Dijkstra eras because: +-- - TxOut ToJSON now uses the experimental Exp.IsEra constraint (Conway+) +-- - TxOut FromJSON uses IsShelleyBasedEra constraint +-- - Roundtrip tests require both encode and decode, so only Conway+ is tested +module Test.Cardano.Api.TxOut.JsonRoundtrip + ( tests + ) +where + +import Cardano.Api + +import Data.Aeson (eitherDecode, encode) + +import Test.Gen.Cardano.Api.TxOut +import Test.Gen.Cardano.Api.Typed + +import Hedgehog (Property, forAll, tripping) +import Hedgehog qualified as H +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +-- | All roundtrip tests +tests :: TestTree +tests = + testGroup + "JsonRoundtrip" + [ testGroup "CtxTx" testsCtxTx + , testGroup "CtxUTxO" testsCtxUTxO + , testGroup "Datum-Specific" testsDatumSpecific + ] + +-- | Roundtrip tests for TxOut CtxTx (Conway era) +-- +-- Note: Dijkstra era is not yet fully supported by shelleyBasedEraConstraints. +testsCtxTx :: [TestTree] +testsCtxTx = + [ testProperty "conway" prop_json_roundtrip_txout_ctx_tx_conway + ] + +-- | Roundtrip tests for TxOut CtxUTxO (Conway era) +-- +-- Note: Dijkstra era is not yet fully supported by shelleyBasedEraConstraints. +testsCtxUTxO :: [TestTree] +testsCtxUTxO = + [ testProperty "conway" prop_json_roundtrip_txout_ctx_utxo_conway + ] + +-- | Datum-specific roundtrip tests (Conway era) +testsDatumSpecific :: [TestTree] +testsDatumSpecific = + [ testProperty "no datum (Conway)" prop_json_roundtrip_txout_no_datum + , testProperty "datum hash (Conway)" prop_json_roundtrip_txout_datum_hash + , testProperty "supplemental datum (Conway)" prop_json_roundtrip_txout_supplemental_datum + , testProperty "inline datum (Conway)" prop_json_roundtrip_txout_inline_datum + ] + +-- ----------------------------------------------------------------------------- +-- CtxTx Roundtrip Properties +-- ----------------------------------------------------------------------------- + +prop_json_roundtrip_txout_ctx_tx_conway :: Property +prop_json_roundtrip_txout_ctx_tx_conway = H.property $ do + txOut <- forAll $ genTxOutTxContext ShelleyBasedEraConway + tripping txOut encode eitherDecode + +-- ----------------------------------------------------------------------------- +-- CtxUTxO Roundtrip Properties +-- ----------------------------------------------------------------------------- + +prop_json_roundtrip_txout_ctx_utxo_conway :: Property +prop_json_roundtrip_txout_ctx_utxo_conway = H.property $ do + txOut <- forAll $ genTxOutUTxOContext ShelleyBasedEraConway + tripping txOut encode eitherDecode + +-- ----------------------------------------------------------------------------- +-- Datum-Specific Roundtrip Properties (Conway era) +-- ----------------------------------------------------------------------------- + +prop_json_roundtrip_txout_no_datum :: Property +prop_json_roundtrip_txout_no_datum = H.property $ do + txOut <- forAll $ genTxOutWithNoDatum ShelleyBasedEraConway + tripping txOut encode eitherDecode + +prop_json_roundtrip_txout_datum_hash :: Property +prop_json_roundtrip_txout_datum_hash = H.property $ do + txOut <- forAll $ genTxOutWithDatumHash AlonzoEraOnwardsConway + tripping txOut encode eitherDecode + +prop_json_roundtrip_txout_supplemental_datum :: Property +prop_json_roundtrip_txout_supplemental_datum = H.property $ do + txOut <- forAll $ genTxOutWithSupplementalDatum AlonzoEraOnwardsConway + tripping txOut encode eitherDecode + +prop_json_roundtrip_txout_inline_datum :: Property +prop_json_roundtrip_txout_inline_datum = H.property $ do + txOut <- forAll $ genTxOutWithInlineDatum BabbageEraOnwardsConway + tripping txOut encode eitherDecode diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index 8e3907f907..33cc2d9349 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -27,6 +27,7 @@ import Test.Cardano.Api.RawBytes qualified import Test.Cardano.Api.Transaction.Autobalance qualified import Test.Cardano.Api.Transaction.Body.Plutus.Scripts qualified import Test.Cardano.Api.TxBody qualified +import Test.Cardano.Api.TxOut.Json qualified import Test.Cardano.Api.Value qualified import Test.Tasty (TestTree, defaultMain, testGroup) @@ -65,5 +66,6 @@ tests = , Test.Cardano.Api.Transaction.Body.Plutus.Scripts.tests , Test.Cardano.Api.Transaction.Autobalance.tests , Test.Cardano.Api.TxBody.tests + , Test.Cardano.Api.TxOut.Json.tests , Test.Cardano.Api.Value.tests ] diff --git a/cardano-wasm/test/cardano-wasm-golden/cardano-wasm-golden.hs b/cardano-wasm/test/cardano-wasm-golden/cardano-wasm-golden.hs index de4594616b..5060d23910 100644 --- a/cardano-wasm/test/cardano-wasm-golden/cardano-wasm-golden.hs +++ b/cardano-wasm/test/cardano-wasm-golden/cardano-wasm-golden.hs @@ -5,4 +5,3 @@ #else main = return () #endif -