Merge pull request #1112 from IntersectMBO/jordan/supplemental-datum-fix

Fix supplemental datum handling in experimental API

Author: Jimbo4350

cardano-api/src/Cardano/Api/Experimental/Tx.hs

@@ -147,6 +147,7 @@ module Cardano.Api.Experimental.Tx
   , setTxProposalProcedures
   , setTxProtocolParams
   , setTxScriptValidity
+  , setTxSupplementalDatums
   , setTxTreasuryDonation
   , setTxValidityLowerBound
   , setTxValidityUpperBound
@@ -157,6 +158,7 @@ module Cardano.Api.Experimental.Tx
   , DatumDecodingError (..)
   , legacyDatumToDatum
   , fromLegacyTxOut
+  , supplementalDatumFromLegacy
 
     -- * TxBodyContent sub type
   , TxCertificates (..)

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/BodyContent/New.hs

@@ -51,6 +51,7 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
   , setTxProposalProcedures
   , setTxProtocolParams
   , setTxScriptValidity
+  , setTxSupplementalDatums
   , setTxTreasuryDonation
   , setTxValidityLowerBound
   , setTxValidityUpperBound
@@ -64,6 +65,7 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
   , DatumDecodingError (..)
   , legacyDatumToDatum
   , fromLegacyTxOut
+  , supplementalDatumFromLegacy
   )
 where
 
@@ -363,11 +365,27 @@ legacyDatumToDatum (OldApi.TxOutDatumInline _ hd) = do
 legacyDatumToDatum OldApi.TxOutDatumNone = Nothing
 
 fromLegacyTxOut
-  :: forall era. IsEra era => OldApi.TxOut CtxTx era -> Either DatumDecodingError (TxOut (LedgerEra era))
+  :: forall era
+   . IsEra era
+  => OldApi.TxOut CtxTx era
+  -> Either DatumDecodingError (TxOut (LedgerEra era), Map L.DataHash (L.Data (LedgerEra era)))
 fromLegacyTxOut tOut@(OldApi.TxOut _ _ d _) = do
   let o = OldApi.toShelleyTxOutAny (convert $ useEra @era) tOut
   newDatum :: L.Datum (LedgerEra era) <- obtainCommonConstraints (useEra @era) $ toLedgerDatum d
-  return $ obtainCommonConstraints (useEra @era) $ TxOut $ o & L.datumTxOutL .~ newDatum
+  let txOut = obtainCommonConstraints (useEra @era) $ TxOut $ o & L.datumTxOutL .~ newDatum
+      suppDats = obtainCommonConstraints (useEra @era) $ supplementalDatumFromLegacy d
+  return (txOut, suppDats)
+
+-- | Extract supplemental datum data from a legacy 'TxOutDatum'.
+-- Returns 'mempty' for non-supplemental datums.
+supplementalDatumFromLegacy
+  :: L.Era (LedgerEra era)
+  => OldApi.TxOutDatum CtxTx era
+  -> Map L.DataHash (L.Data (LedgerEra era))
+supplementalDatumFromLegacy (OldApi.TxOutSupplementalDatum _ h) =
+  let ledgerData = Api.toAlonzoData h
+   in fromList [(L.hashData ledgerData, ledgerData)]
+supplementalDatumFromLegacy _ = mempty
 
 newtype DatumDecodingError = DatumDecodingError String
   deriving (Show, Eq)
@@ -381,9 +399,7 @@ toLedgerDatum
 toLedgerDatum OldApi.TxOutDatumNone = Right L.NoDatum
 toLedgerDatum (OldApi.TxOutDatumHash _ (Api.ScriptDataHash h)) = Right $ L.DatumHash h
 toLedgerDatum (OldApi.TxOutSupplementalDatum _ h) =
-  case L.makeBinaryData $ SBS.toShort $ Api.getOriginalScriptDataBytes h of
-    Left e -> Left $ DatumDecodingError e
-    Right bd -> Right $ L.Datum bd
+  Right $ L.DatumHash (Api.unScriptDataHash $ Api.hashScriptDataBytes h)
 toLedgerDatum (OldApi.TxOutDatumInline _ h) =
   case L.makeBinaryData $ SBS.toShort $ Api.getOriginalScriptDataBytes h of
     Left e -> Left $ DatumDecodingError e
@@ -538,6 +554,9 @@ data TxBodyContent era
   -- ^ Current treasury value
   , txTreasuryDonation :: Maybe L.Coin
   -- ^ Treasury donation to perform
+  , txSupplementalDatums :: Map L.DataHash (L.Data era)
+  -- ^ Supplemental datums are datums whose hashes correspond to output datum hashes.
+  -- They are included in the transaction witness set for communication purposes only.
   }
 
 defaultTxBodyContent
@@ -565,6 +584,7 @@ defaultTxBodyContent =
     , txVotingProcedures = Nothing
     , txCurrentTreasuryValue = Nothing
     , txTreasuryDonation = Nothing
+    , txSupplementalDatums = mempty
     }
 
 extractAllIndexedPlutusScriptWitnesses
@@ -704,18 +724,18 @@ collectTxBodyScriptWitnessRequirements
   TxBodyContent
     { txIns
     , txInsReference
-    , txOuts
     , txCertificates
     , txMintValue
     , txWithdrawals
     , txVotingProcedures
     , txProposalProcedures
+    , txSupplementalDatums
     } = obtainCommonConstraints (useEra @era) $ do
     let supplementaldatums =
           TxScriptWitnessRequirements
             mempty
             mempty
-            (getDatums txInsReference txOuts)
+            (getDatums txInsReference txSupplementalDatums)
             mempty
 
     let txInWits =
@@ -756,34 +776,30 @@ obtainMonoidConstraint eon = case eon of
   ConwayEra -> id
   DijkstraEra -> id
 
--- | Extract datum:
--- 1. supplemental datums from transaction outputs
+-- | Collect datums for the transaction witness set ('TxDats'):
+-- 1. supplemental datums provided explicitly
 -- 2. datums from reference inputs
 --
+-- Supplemental datums are datums whose hashes correspond to datum hashes
+-- in transaction outputs. They are included for communication purposes only
+-- (the Alonzo ledger spec uses subset equality for these).
+--
 -- Note that this function does not check whose datum hashes are present in the reference inputs. This means if there
 -- are redundant datums in 'TxInsReference', a submission of such transaction will fail.
 getDatums
   :: forall era
    . IsEra era
   => TxInsReference (LedgerEra era)
   -- ^ reference inputs
-  -> [TxOut (LedgerEra era)]
+  -> Map L.DataHash (L.Data (LedgerEra era))
+  -- ^ supplemental datums
   -> L.TxDats (LedgerEra era)
-getDatums txInsRef txOutsFromTx = do
+getDatums txInsRef supplementalDats = do
   let TxInsReference _ datumSet = txInsRef
       refInDatums = mapMaybe extractDatumsAndHashes $ Set.toList datumSet
-      -- use only supplemental datum
-      txOutsDats =
-        [ (L.hashData d, d)
-        | TxOut txout <- txOutsFromTx
-        , d <-
-            maybeToList $ L.strictMaybeToMaybe $ txout ^. obtainCommonConstraints (useEra @era) L.dataTxOutL
-        ]
-          :: [(L.DataHash, L.Data (LedgerEra era))]
   obtainCommonConstraints (useEra @era) $
     L.TxDats $
-      fromList $
-        refInDatums <> txOutsDats
+      fromList refInDatums <> supplementalDats
 
 -- Getters and Setters
 
@@ -850,6 +866,9 @@ setTxCurrentTreasuryValue v txBodyContent = txBodyContent{txCurrentTreasuryValue
 setTxTreasuryDonation :: L.Coin -> TxBodyContent era -> TxBodyContent era
 setTxTreasuryDonation v txBodyContent = txBodyContent{txTreasuryDonation = Just v}
 
+setTxSupplementalDatums :: Map L.DataHash (L.Data era) -> TxBodyContent era -> TxBodyContent era
+setTxSupplementalDatums v txBodyContent = txBodyContent{txSupplementalDatums = v}
+
 modTxOuts
   :: ([TxOut era] -> [TxOut era]) -> TxBodyContent era -> TxBodyContent era
 modTxOuts f txBodyContent = txBodyContent{txOuts = f (txOuts txBodyContent)}

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Fee.hs

@@ -733,6 +733,7 @@ substituteExecutionUnits
                     txVotingProcedures
                     _
                     _
+                    _
                   ) = do
     mappedTxIns <- mapScriptWitnessesTxIns txIns
     mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals