Fix bug related to non-canonical inline datums in UTxO JSON round-trips

hydra-cardano-api/hydra-cardano-api.cabal

@@ -73,6 +73,7 @@ library
   build-depends:
     , aeson                   >=2
     , base                    >=4.14
+    , base16-bytestring
     , bytestring
     , cardano-api             ^>=11.1
     , cardano-binary

hydra-cardano-api/src/Hydra/Cardano/Api/TxOut.hs

@@ -9,6 +9,11 @@ import Cardano.Ledger.Api qualified as Ledger
 import Cardano.Ledger.Babbage.TxInfo qualified as Ledger
 import Cardano.Ledger.BaseTypes qualified as Ledger
 import Cardano.Ledger.Credential qualified as Ledger
+import Data.Aeson ((.:?))
+import Data.Aeson qualified as Aeson
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Aeson.Types (Parser)
+import Data.ByteString.Base16 qualified as Base16
 import Data.List qualified as List
 import Hydra.Cardano.Api.AddressInEra (fromPlutusAddress)
 import Hydra.Cardano.Api.Hash (unsafeScriptDataHashFromBytes)
@@ -132,6 +137,47 @@ isScriptTxOut script txOut =
 
   (TxOut address _ _ _) = txOut
 
+-- * JSON parsing
+
+-- | Parse a 'TxOut' from JSON, correctly handling non-canonical inline datums.
+--
+-- cardano-api's 'FromJSON' for 'TxOut' ignores the @inlineDatumRaw@ field and
+-- reconstructs 'HashableScriptData' via 'scriptDataFromJson', which re-serialises
+-- canonically. For non-canonical CBOR datums, H(canonical) ≠ H(original) causing
+-- \"Inline datum not equivalent to inline datum hash\" on replay from the event DB.
+--
+-- This function reads @inlineDatumRaw@ first. When present it deserialises the
+-- original bytes directly (preserving them), patches @inlineDatumhash@ in the
+-- JSON to the canonical hash so the cardano-api parser succeeds, then replaces
+-- the datum with one carrying the original bytes.
+-- FIXME: Once this PR is merged
+-- https://github.com/IntersectMBO/cardano-api/pull/1238
+-- revisit and remove the diff added in
+-- https://github.com/cardano-scaling/hydra/pull/2746
+-- to fix this issue.
+parseTxOutFromJSON :: Aeson.Value -> Parser (TxOut CtxUTxO Era)
+parseTxOutFromJSON v@(Aeson.Object o) = do
+  mRawHex <- o .:? "inlineDatumRaw"
+  case mRawHex of
+    Nothing ->
+      parseJSON v
+    Just rawHex -> do
+      rawBytes <- either fail pure $ Base16.decode (encodeUtf8 rawHex)
+      hsd <- either (fail . show) pure $ deserialiseFromCBOR AsHashableScriptData rawBytes
+      let canonicalHsd = unsafeHashableScriptData (getScriptData hsd)
+          patchedVal =
+            Aeson.Object $
+              KeyMap.insert "inlineDatumhash" (toJSON $ hashScriptDataBytes canonicalHsd) o
+      txOut <- parseJSON patchedVal
+      pure $
+        modifyTxOutDatum
+          ( \case
+              TxOutDatumInline{} -> TxOutDatumInline babbageBasedEra hsd
+              d -> d
+          )
+          txOut
+parseTxOutFromJSON v = parseJSON v
+
 -- * Type Conversions
 
 -- | Convert a cardano-ledger 'TxOut' into a cardano-api 'TxOut'

hydra-cardano-api/src/Hydra/Cardano/Api/UTxO.hs

@@ -2,17 +2,35 @@ module Hydra.Cardano.Api.UTxO where
 
 import Hydra.Cardano.Api.Prelude hiding (fromLedgerUTxO)
 import Hydra.Cardano.Api.TxIn (txIns')
+import Hydra.Cardano.Api.TxOut (parseTxOutFromJSON)
 
 import Cardano.Api.UTxO qualified as UTxO
 import Cardano.Ledger.Api (outputsTxBodyL)
 import Cardano.Ledger.BaseTypes qualified as Ledger
 import Cardano.Ledger.Shelley.UTxO qualified as Ledger
 import Cardano.Ledger.TxIn qualified as Ledger
 import Control.Lens ((^.))
+import Data.Aeson qualified as Aeson
+import Data.Aeson.Key qualified as Key
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Aeson.Types (Parser)
 import Data.Foldable (toList)
 import Data.Map.Strict qualified as Map
 import Data.Maybe (mapMaybe)
 
+-- | Parse a 'UTxO' from JSON using 'parseTxOutFromJSON' to correctly handle
+-- non-canonical inline datums. See 'parseTxOutFromJSON' for details.
+parseUTxOFromJSON :: Aeson.Value -> Parser (UTxO Era)
+parseUTxOFromJSON = Aeson.withObject "UTxO" $ \hm -> do
+  pairs <- mapM parsePair (KeyMap.toList hm)
+  pure $ UTxO.fromList pairs
+ where
+  parsePair :: (KeyMap.Key, Aeson.Value) -> Parser (TxIn, TxOut CtxUTxO Era)
+  parsePair (k, txOutVal) = do
+    txIn <- parseJSON (Aeson.String $ Key.toText k)
+    txOut <- parseTxOutFromJSON txOutVal
+    pure (txIn, txOut)
+
 -- | Construct a UTxO from a transaction. This constructs artificial `TxIn`
 -- (a.k.a output reference) from the transaction itself, zipping them to the
 -- outputs they correspond to.

hydra-node/test/Hydra/Ledger/CardanoSpec.hs

@@ -14,6 +14,8 @@ import Cardano.Slotting.Time (RelativeTime (..), mkSlotLength)
 import Data.Aeson (eitherDecode, encode)
 import Data.Aeson qualified as Aeson
 import Data.Aeson.Lens (key)
+import Data.Aeson.Types (parseEither)
+import Data.ByteString qualified as BS
 import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne))
 import Data.Text (unpack)
 import GHC.IsList (IsList (..))
@@ -49,11 +51,13 @@ import Test.Hydra.Tx.Gen (genKeyPair, genOneUTxOFor, genOutputFor, genTxOut, gen
 import Test.QuickCheck (
   Property,
   checkCoverage,
+  choose,
   conjoin,
   counterexample,
   cover,
   forAll,
   forAllBlind,
+  listOf1,
   property,
   (===),
  )
@@ -136,6 +140,39 @@ spec =
               \   \"value\":{\"lovelace\":14}}}"
         shouldParseJSONAs @UTxO bs
 
+      xprop "round-trips TxOut with non-canonical inline datum via cardano-api FromJSON (pending cardano-api fix)" $
+        forAll genNonCanonicalHashableScriptData $ \hsd ->
+          let (vk, _) = genKeyPair `generateWith` 42
+              addr = mkVkAddress testNetworkId vk
+              txOut =
+                TxOut
+                  addr
+                  (lovelaceToValue 2_000_000)
+                  (TxOutDatumInline hsd)
+                  ReferenceScriptNone ::
+                  TxOut CtxUTxO
+           in case Aeson.eitherDecode @(TxOut CtxUTxO) (Aeson.encode txOut) of
+                Left err -> counterexample err False
+                Right _ -> property True
+
+      prop "parseTxOutFromJSON preserves hash for non-canonical inline datum" $
+        forAll genNonCanonicalHashableScriptData $ \hsd ->
+          let (vk, _) = genKeyPair `generateWith` 42
+              addr = mkVkAddress testNetworkId vk
+              txOut =
+                TxOut
+                  addr
+                  (lovelaceToValue 2_000_000)
+                  (TxOutDatumInline hsd)
+                  ReferenceScriptNone ::
+                  TxOut CtxUTxO
+           in case parseEither parseTxOutFromJSON (Aeson.toJSON txOut) of
+                Left err -> counterexample err False
+                Right (TxOut _ _ (TxOutDatumInline hsd') _) ->
+                  hashScriptDataBytes hsd === hashScriptDataBytes hsd'
+                Right _ ->
+                  counterexample "Expected TxOutDatumInline after round-trip" False
+
     describe "PParams" $
       prop "Roundtrip JSON encoding" roundtripPParams
 
@@ -380,3 +417,19 @@ multiEraHistory =
             , eraPerasRoundLength = NoPerasEnabled
             }
       }
+
+-- | Generate 'HashableScriptData' whose CBOR uses a definite-length array for
+-- constructor fields instead of the Plutus-canonical indefinite-length form.
+-- Both encodings are valid on L1, but cardano-api's 'FromJSON' re-canonicalises,
+-- producing a different hash — the root cause of the replay crash-loop.
+genNonCanonicalHashableScriptData :: Gen HashableScriptData
+genNonCanonicalHashableScriptData = do
+  constrIdx <- choose (0, 6 :: Int)
+  args <- listOf1 $ choose (0, 23 :: Int)
+  let tagBytes = [0xd8, 0x79 + fromIntegral constrIdx] :: [Word8]
+      arrayHdr = [0x80 + fromIntegral (length args)] :: [Word8]
+      argBytes = map fromIntegral args :: [Word8]
+      bytes = BS.pack (tagBytes <> arrayHdr <> argBytes)
+  case deserialiseFromCBOR AsHashableScriptData bytes of
+    Left _ -> genNonCanonicalHashableScriptData
+    Right hsd -> pure hsd

hydra-tx/src/Hydra/Tx/IsTx.hs

@@ -205,3 +205,6 @@ instance IsTx Tx where
     case toPlutusTxOut txOut of
       Just plutusTxOut -> fromBuiltin (Util.hashTxOuts [plutusTxOut])
       Nothing -> mempty -- Should not happen for valid UTxO
+
+instance {-# OVERLAPPING #-} FromJSON UTxO where
+  parseJSON = parseUTxOFromJSON