Fix non-canonical inline datum JSON round-trip

.changes/20260625_fix_non_canonical_inline_datum_json_roundtrip.yml

@@ -0,0 +1,7 @@
+project: cardano-api
+pr: 1238
+kind:
+  - bugfix
+description: |
+  FromJSON (TxOut) crashes when parsing a TxOut whose inline datum was encoded with non-canonical CBOR bytes (e.g. definite-length arrays instead of the indefinite-length form Plutus normally emits).
+

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -44,6 +44,7 @@ module Test.Gen.Cardano.Api.Typed
 
     -- * Scripts
   , genHashableScriptData
+  , genNonCanonicalHashableScriptData
   , genReferenceScript
   , genScript
   , genValidScript
@@ -188,7 +189,7 @@ import Data.Int (Int64)
 import Data.Maybe
 import Data.Ratio (Ratio, (%))
 import Data.String
-import Data.Word (Word32, Word64)
+import Data.Word (Word32, Word64, Word8)
 import GHC.Exts (IsList (..))
 import GHC.Stack
 import Numeric.Natural (Natural)
@@ -391,6 +392,26 @@ genHashableScriptData = do
     Left e -> error $ "genHashableScriptData: " <> show e
     Right r -> return r
 
+-- | Generate 'HashableScriptData' whose CBOR uses a definite-length array
+-- instead of the canonical indefinite-length form that Plutus normally emits.
+-- This means 'hashScriptDataBytes' of the result differs from
+-- 'hashScriptDataBytes' of its canonical re-encoding, exposing any JSON
+-- round-trip that reconstructs CBOR rather than preserving original bytes.
+genNonCanonicalHashableScriptData :: HasCallStack => Gen HashableScriptData
+genNonCanonicalHashableScriptData = do
+  constrIdx <- Gen.integral (Range.linear 0 6 :: Range.Range Int)
+  args <- Gen.list (Range.linear 1 5) (Gen.integral (Range.linear 0 23 :: Range.Range Int))
+  -- Plutus constructor n uses CBOR tag 121+n.
+  -- Canonical encoding wraps fields in an indefinite-length array (0x9f..0xff).
+  -- We use a definite-length array (0x80+len) to produce non-canonical bytes.
+  let tagBytes = [0xd8, fromIntegral (0x79 + constrIdx)] :: [Word8]
+      arrayHdr = [fromIntegral (0x80 + length args)] :: [Word8]
+      argBytes = map fromIntegral args :: [Word8]
+      bytes = BS.pack (tagBytes <> arrayHdr <> argBytes)
+  case deserialiseFromCBOR AsHashableScriptData bytes of
+    Left e -> error $ "genNonCanonicalHashableScriptData: " <> show e
+    Right r -> pure r
+
 {-# DEPRECATED genScriptData "Use genHashableScriptData" #-}
 genScriptData :: Gen ScriptData
 genScriptData =

cardano-api/src/Cardano/Api/Tx/Internal/Output.hs

@@ -431,6 +431,26 @@ txOutToJsonValue era (TxOut addr val dat refScript) =
       ReferenceScript _ s -> toJSON s
       ReferenceScriptNone -> Aeson.Null
 
+-- | Parse 'HashableScriptData' from a JSON object, preferring the raw CBOR
+-- bytes in @inlineDatumRaw@ when present to preserve non-canonical encodings,
+-- falling back to the supplied parser for JSON that lacks the field.
+parseInlineDatum
+  :: Aeson.Object
+  -> Aeson.Value
+  -> Hash ScriptData
+  -> (Aeson.Value -> Aeson.Parser HashableScriptData)
+  -> Aeson.Parser HashableScriptData
+parseInlineDatum o dVal h fallback = do
+  mRaw <- o .:? "inlineDatumRaw"
+  hashableData <- case mRaw of
+    Just rawHex -> do
+      rawBytes <- either fail pure $ Base16.decode (Text.encodeUtf8 rawHex)
+      either (fail . show) pure $ deserialiseFromCBOR AsHashableScriptData rawBytes
+    Nothing -> fallback dVal
+  if hashScriptDataBytes hashableData /= h
+    then fail "Inline datum not equivalent to inline datum hash"
+    else pure hashableData
+
 instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where
   parseJSON = withObject "TxOut" $ \o -> do
     case shelleyBasedEra :: ShelleyBasedEra era of
@@ -462,13 +482,12 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
             (Just dVal, Just h) -> do
-              case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right hashableData -> do
-                  if hashScriptDataBytes hashableData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataJsonToHashable ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right hsd -> pure hsd
+              return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail
@@ -485,14 +504,13 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where
         inlineDatum <- o .:? "inlineDatum"
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
-            (Just dVal, Just h) ->
-              case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right sData ->
-                  if hashScriptDataBytes sData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsConway sData
+            (Just dVal, Just h) -> do
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataFromJson ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right sData -> pure sData
+              return $ TxOutDatumInline BabbageEraOnwardsConway hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail
@@ -509,14 +527,13 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxTx era) where
         inlineDatum <- o .:? "inlineDatum"
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
-            (Just dVal, Just h) ->
-              case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right sData ->
-                  if hashScriptDataBytes sData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsDijkstra sData
+            (Just dVal, Just h) -> do
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataFromJson ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right sData -> pure sData
+              return $ TxOutDatumInline BabbageEraOnwardsDijkstra hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail
@@ -645,13 +662,12 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
             (Just dVal, Just h) -> do
-              case scriptDataJsonToHashable ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right hashableData -> do
-                  if hashScriptDataBytes hashableData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataJsonToHashable ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right hsd -> pure hsd
+              return $ TxOutDatumInline BabbageEraOnwardsBabbage hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail
@@ -669,14 +685,13 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where
         inlineDatum <- o .:? "inlineDatum"
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
-            (Just dVal, Just h) ->
-              case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right sData ->
-                  if hashScriptDataBytes sData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsConway sData
+            (Just dVal, Just h) -> do
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataFromJson ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right sData -> pure sData
+              return $ TxOutDatumInline BabbageEraOnwardsConway hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail
@@ -694,14 +709,13 @@ instance IsShelleyBasedEra era => FromJSON (TxOut CtxUTxO era) where
         inlineDatum <- o .:? "inlineDatum"
         mInlineDatum <-
           case (inlineDatum, inlineDatumHash) of
-            (Just dVal, Just h) ->
-              case scriptDataFromJson ScriptDataJsonDetailedSchema dVal of
-                Left err ->
-                  fail $ "Error parsing TxOut JSON: " <> displayError err
-                Right sData ->
-                  if hashScriptDataBytes sData /= h
-                    then fail "Inline datum not equivalent to inline datum hash"
-                    else return $ TxOutDatumInline BabbageEraOnwardsDijkstra sData
+            (Just dVal, Just h) -> do
+              hashableData <-
+                parseInlineDatum o dVal h $ \v ->
+                  case scriptDataFromJson ScriptDataJsonDetailedSchema v of
+                    Left err -> fail $ "Error parsing TxOut JSON: " <> displayError err
+                    Right sData -> pure sData
+              return $ TxOutDatumInline BabbageEraOnwardsDijkstra hashableData
             (Nothing, Nothing) -> return TxOutDatumNone
             (_, _) ->
               fail

cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs

@@ -54,6 +54,22 @@ prop_json_roundtrip_txout_utxo_context = H.property $ do
   txOut <- forAll $ genTxOutUTxOContext ShelleyBasedEraBabbage
   tripping txOut encode eitherDecode
 
+-- | Round-trips a 'TxOut' whose inline datum uses non-canonical CBOR bytes
+-- (definite-length array instead of the canonical indefinite-length form).
+prop_json_roundtrip_txout_noncanonical_inline_datum :: Property
+prop_json_roundtrip_txout_noncanonical_inline_datum = H.property $ do
+  hsd <- forAll genNonCanonicalHashableScriptData
+  addr <- forAll $ genAddressInEra ShelleyBasedEraConway
+  val <- forAll $ genTxOutValue ShelleyBasedEraConway
+  let txOutUTxO =
+        TxOut addr val (TxOutDatumInline BabbageEraOnwardsConway hsd) ReferenceScriptNone
+          :: TxOut CtxUTxO ConwayEra
+      txOutTx =
+        TxOut addr val (TxOutDatumInline BabbageEraOnwardsConway hsd) ReferenceScriptNone
+          :: TxOut CtxTx ConwayEra
+  tripping txOutUTxO encode eitherDecode
+  tripping txOutTx encode eitherDecode
+
 prop_json_roundtrip_scriptdata_detailed_json :: Property
 prop_json_roundtrip_scriptdata_detailed_json = H.property $ do
   sData <- forAll genHashableScriptData
@@ -103,6 +119,7 @@ tests =
     , testProperty "json roundtrip txoutvalue" prop_json_roundtrip_txoutvalue
     , testProperty "json roundtrip txout tx context" prop_json_roundtrip_txout_tx_context
     , testProperty "json roundtrip txout utxo context" prop_json_roundtrip_txout_utxo_context
+    , testProperty "json roundtrip txout noncanonical inline datum" prop_json_roundtrip_txout_noncanonical_inline_datum
     , testProperty "json roundtrip scriptdata detailed json" prop_json_roundtrip_scriptdata_detailed_json
     , testProperty "json roundtrip praos nonce" prop_roundtrip_praos_nonce_JSON
     , testProperty "new TxOut ToJSON matches legacy" prop_new_txout_json_matches_legacy