diff --git a/.changes/20260625_fix_non_canonical_inline_datum_json_roundtrip.yml b/.changes/20260625_fix_non_canonical_inline_datum_json_roundtrip.yml new file mode 100644 index 0000000000..9e87a60876 --- /dev/null +++ b/.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). + diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 841d484318..817ff566f2 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/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 = diff --git a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs b/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs index b22fec6205..ccc4e98e7b 100644 --- a/cardano-api/src/Cardano/Api/Tx/Internal/Output.hs +++ b/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 diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs index 6593fd9d9f..1705065e7c 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Json.hs +++ b/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