Merge pull request #814 from IntersectMBO/mgalazyn/feature/add-supplemental-data-from-txins

Allow providing of actual datum for reference inputs

Author: carbolymer

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

@@ -144,7 +144,7 @@ where
 
 import           Cardano.Api hiding (txIns)
 import qualified Cardano.Api as Api
-import qualified Cardano.Api.Experimental as Exp 
+import qualified Cardano.Api.Experimental as Exp
 import           Cardano.Api.Byron (KeyWitness (ByronKeyWitness),
                    WitnessNetworkIdOrByronAddress (..))
 import qualified Cardano.Api.Byron as Byron
@@ -965,11 +965,17 @@ genTxInsCollateral =
           ]
     )
 
-genTxInsReference :: CardanoEra era -> Gen (TxInsReference era)
+genTxInsReference
+  :: Applicative (BuildTxWith build)
+  => CardanoEra era
+  -> Gen (TxInsReference build era)
 genTxInsReference =
   caseByronToAlonzoOrBabbageEraOnwards
     (const (pure TxInsReferenceNone))
-    (\w -> TxInsReference w <$> Gen.list (Range.linear 0 10) genTxIn)
+    (\w -> do
+      txIns <- Gen.list (Range.linear 0 10) genTxIn
+      pure $ TxInsReference w txIns mempty
+    )
 
 genTxReturnCollateral :: ShelleyBasedEra era -> Gen (TxReturnCollateral CtxTx era)
 genTxReturnCollateral era =
@@ -1022,7 +1028,7 @@ genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness
 
 -- | This generator validates generated 'TxBodyContent' and backtracks when the generated body
 -- fails the validation. That also means that it is quite slow.
-genValidTxBody :: Typeable era 
+genValidTxBody :: Typeable era
                => ShelleyBasedEra era
                -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent'
 genValidTxBody sbe =
@@ -1135,7 +1141,6 @@ genShelleyBootstrapWitness sbe =
     <*> (fst <$> genValidTxBody sbe)
     <*> genSigningKey AsByronKey
 
- 
 genShelleyKeyWitness
   :: ()
   => Typeable era
@@ -1385,39 +1390,39 @@ genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin
 genTreasuryDonation _era = Q.arbitrary
 
 genWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.TxInItem era)
-genWitnessable = Exp.WitTxIn <$> genTxIn  
+genWitnessable = Exp.WitTxIn <$> genTxIn
 
 genMintWitnessable :: L.AlonzoEraScript era => Gen (Exp.Witnessable Exp.MintItem era)
-genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets 
+genMintWitnessable = Exp.WitMint <$> genPolicyId <*> genPolicyAssets
 
-genIndexedPlutusScriptWitness 
-  :: L.AlonzoEraScript (ShelleyLedgerEra era) 
+genIndexedPlutusScriptWitness
+  :: L.AlonzoEraScript (ShelleyLedgerEra era)
   => Gen (Exp.IndexedPlutusScriptWitness Exp.TxInItem L.PlutusV3 Exp.SpendingScript (ShelleyLedgerEra era))
 genIndexedPlutusScriptWitness =  do
     index <- Gen.word32 $ Range.linear 1 10
     witnessable <- genWitnessable
-    Exp.IndexedPlutusScriptWitness 
+    Exp.IndexedPlutusScriptWitness
        <$> genWitnessable
        <*> genPlutusPurpose index witnessable
-       <*> genPlutusScriptWitness 
+       <*> genPlutusScriptWitness
 
-genPlutusPurpose 
-  :: Word32 
-  -> Exp.Witnessable thing (ShelleyLedgerEra era) 
+genPlutusPurpose
+  :: Word32
+  -> Exp.Witnessable thing (ShelleyLedgerEra era)
   -> Gen (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
 genPlutusPurpose index wit = return $ Exp.toPlutusScriptPurpose index wit
 
 genPlutusScriptWitness :: Gen (Exp.PlutusScriptWitness L.PlutusV3 purpose era)
-genPlutusScriptWitness = do 
+genPlutusScriptWitness = do
   let l = Exp.toPlutusSLanguage PlutusScriptV3
-  Exp.PlutusScriptWitness l . Exp.PReferenceScript 
+  Exp.PlutusScriptWitness l . Exp.PReferenceScript
     <$> genTxIn
     <*> genPlutusScriptDatum
     <*> genHashableScriptData
-    <*> genExecutionUnits 
+    <*> genExecutionUnits
 
 genPlutusScriptDatum :: Gen (Exp.PlutusScriptDatum lang purpose)
-genPlutusScriptDatum = return Exp.NoScriptDatum 
+genPlutusScriptDatum = return Exp.NoScriptDatum
 
 -- | This generator does not generate a valid witness - just a random one.
 genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)

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

@@ -301,6 +301,8 @@ module Cardano.Api.Internal.Tx.Body
     -- ** Other transaction body types
   , TxInsCollateral (..)
   , TxInsReference (..)
+  , TxInsReferenceDatums
+  , getReferenceInputDatumMap
   , TxReturnCollateral (..)
   , TxTotalCollateral (..)
   , TxFee (..)
@@ -570,16 +572,31 @@ deriving instance Eq (TxTotalCollateral era)
 
 deriving instance Show (TxTotalCollateral era)
 
-data TxInsReference era where
-  TxInsReferenceNone :: TxInsReference era
+data TxInsReference build era where
+  TxInsReferenceNone :: TxInsReference build era
   TxInsReference
     :: BabbageEraOnwards era
     -> [TxIn]
-    -> TxInsReference era
+    -- ^ A list of reference inputs
+    -> TxInsReferenceDatums build
+    -- ^ A set of datums, whose hashes are referenced in UTXO of reference inputs. Those datums will be inserted
+    -- to the datum map available to the scripts. Note that inserting a datum with hash not present in the reference
+    -- input will result in an error on transaction submission.
+    -> TxInsReference build era
 
-deriving instance Eq (TxInsReference era)
+deriving instance Eq (TxInsReference build era)
 
-deriving instance Show (TxInsReference era)
+deriving instance Show (TxInsReference build era)
+
+-- | The actual datums, referenced by hash in the transaction reference inputs.
+type TxInsReferenceDatums build = BuildTxWith build (Set HashableScriptData)
+
+getReferenceInputDatumMap
+  :: TxInsReferenceDatums build
+  -> Map (Hash ScriptData) HashableScriptData
+getReferenceInputDatumMap = \case
+  ViewTx -> mempty
+  BuildTxWith datumSet -> fromList $ map (\h -> (hashScriptDataBytes h, h)) $ toList datumSet
 
 -- ----------------------------------------------------------------------------
 -- Transaction fees
@@ -984,7 +1001,7 @@ data TxBodyContent build era
   = TxBodyContent
   { txIns :: TxIns build era
   , txInsCollateral :: TxInsCollateral era
-  , txInsReference :: TxInsReference era
+  , txInsReference :: TxInsReference build era
   , txOuts :: [TxOut CtxTx era]
   , txTotalCollateral :: TxTotalCollateral era
   , txReturnCollateral :: TxReturnCollateral CtxTx era
@@ -1075,25 +1092,36 @@ addTxInCollateral
   :: IsAlonzoBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
 addTxInCollateral txInCollateral = addTxInsCollateral [txInCollateral]
 
-setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era
+setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era
 setTxInsReference v txBodyContent = txBodyContent{txInsReference = v}
 
 modTxInsReference
-  :: (TxInsReference era -> TxInsReference era) -> TxBodyContent build era -> TxBodyContent build era
+  :: (TxInsReference build era -> TxInsReference build era)
+  -> TxBodyContent build era
+  -> TxBodyContent build era
 modTxInsReference f txBodyContent = txBodyContent{txInsReference = f (txInsReference txBodyContent)}
 
 addTxInsReference
-  :: IsBabbageBasedEra era => [TxIn] -> TxBodyContent build era -> TxBodyContent build era
-addTxInsReference txInsReference =
-  modTxInsReference
-    ( \case
-        TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference
-        TxInsReference era xs -> TxInsReference era (xs <> txInsReference)
-    )
+  :: Applicative (BuildTxWith build)
+  => IsBabbageBasedEra era
+  => [TxIn]
+  -> Set HashableScriptData
+  -> TxBodyContent build era
+  -> TxBodyContent build era
+addTxInsReference txInsReference scriptData =
+  modTxInsReference $
+    \case
+      TxInsReferenceNone -> TxInsReference babbageBasedEra txInsReference (pure scriptData)
+      TxInsReference era xs bScriptData' -> TxInsReference era (xs <> txInsReference) ((<> scriptData) <$> bScriptData')
 
 addTxInReference
-  :: IsBabbageBasedEra era => TxIn -> TxBodyContent build era -> TxBodyContent build era
-addTxInReference txInReference = addTxInsReference [txInReference]
+  :: Applicative (BuildTxWith build)
+  => IsBabbageBasedEra era
+  => TxIn
+  -> Maybe HashableScriptData
+  -> TxBodyContent build era
+  -> TxBodyContent build era
+addTxInReference txInReference mDatum = addTxInsReference [txInReference] . fromList $ maybeToList mDatum
 
 setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era
 setTxOuts v txBodyContent = txBodyContent{txOuts = v}
@@ -1742,11 +1770,11 @@ fromLedgerTxInsCollateral sbe body =
     sbe
 
 fromLedgerTxInsReference
-  :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era
+  :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era
 fromLedgerTxInsReference sbe txBody =
   caseShelleyToAlonzoOrBabbageEraOnwards
     (const TxInsReferenceNone)
-    (\w -> TxInsReference w $ map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL)
+    (\w -> TxInsReference w (map fromShelleyTxIn . toList $ txBody ^. L.referenceInputsTxBodyL) ViewTx)
     sbe
 
 fromLedgerTxTotalCollateral
@@ -2108,11 +2136,11 @@ convPParamsToScriptIntegrityHash
   -> Alonzo.TxDats (ShelleyLedgerEra era)
   -> Set Plutus.Language
   -> StrictMaybe L.ScriptIntegrityHash
-convPParamsToScriptIntegrityHash w txProtocolParams redeemers datums languages =
+convPParamsToScriptIntegrityHash w (BuildTxWith mTxProtocolParams) redeemers datums languages =
   alonzoEraOnwardsConstraints w $
-    case txProtocolParams of
-      BuildTxWith Nothing -> SNothing
-      BuildTxWith (Just (LedgerProtocolParameters pp)) ->
+    case mTxProtocolParams of
+      Nothing -> SNothing
+      Just (LedgerProtocolParameters pp) ->
         Alonzo.hashScriptIntegrity (Set.map (L.getLanguageView pp) languages) redeemers datums
 
 convLanguages :: [(ScriptWitnessIndex, AnyScriptWitness era)] -> Set Plutus.Language
@@ -2122,11 +2150,11 @@ convLanguages witnesses =
     | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses
     ]
 
-convReferenceInputs :: TxInsReference era -> Set Ledger.TxIn
+convReferenceInputs :: TxInsReference build era -> Set Ledger.TxIn
 convReferenceInputs txInsReference =
   case txInsReference of
     TxInsReferenceNone -> mempty
-    TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins
+    TxInsReference _ refTxins _ -> fromList $ map toShelleyTxIn refTxins
 
 -- | Returns an OSet of proposals from 'TxProposalProcedures'.
 convProposalProcedures
@@ -2994,11 +3022,17 @@ collectTxBodyScriptWitnessRequirements
 collectTxBodyScriptWitnessRequirements
   aEon
   bc@TxBodyContent
-    { txOuts
+    { txInsReference
+    , txOuts
     } =
     obtainAlonzoScriptPurposeConstraints aEon $ do
       let sbe = shelleyBasedEra @era
-          supplementaldatums = TxScriptWitnessRequirements mempty mempty (getSupplementalDatums aEon txOuts) mempty
+          supplementaldatums =
+            TxScriptWitnessRequirements
+              mempty
+              mempty
+              (getDatums aEon txInsReference txOuts)
+              mempty
       txInWits <-
         first TxBodyPlutusScriptDecodeError $
           legacyWitnessToScriptRequirements aEon $
@@ -3052,19 +3086,32 @@ collectTxBodyScriptWitnessRequirements
             , txProposalWits
             ]
 
-getSupplementalDatums
+-- | Extract datum:
+-- 1. supplemental datums from transaction outputs
+-- 2. datums from reference inputs
+--
+-- Note that this function does not check whose datum 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
   :: AlonzoEraOnwards era
+  -> TxInsReference BuildTx era
+  -- ^ reference inputs
   -> [TxOut CtxTx era]
   -> L.TxDats (ShelleyLedgerEra era)
-getSupplementalDatums eon [] = alonzoEraOnwardsConstraints eon mempty
-getSupplementalDatums eon txouts =
-  alonzoEraOnwardsConstraints eon $
-    L.TxDats $
-      fromList
-        [ (L.hashData ledgerData, ledgerData)
-        | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txouts
-        , let ledgerData = toAlonzoData d
+getDatums eon txInsRef txOutsFromTx = alonzoEraOnwardsConstraints eon $ do
+  let refTxInsDats =
+        [ d
+        | TxInsReference _ _ (BuildTxWith datumSet) <- [txInsRef]
+        , d <- toList datumSet
         ]
+      -- use only supplemental datum
+      txOutsDats = [d | TxOut _ _ (TxOutSupplementalDatum _ d) _ <- txOutsFromTx]
+  L.TxDats $
+    fromList $
+      [ (L.hashData ledgerData, ledgerData)
+      | d <- refTxInsDats <> txOutsDats
+      , let ledgerData = toAlonzoData d
+      ]
 
 extractWitnessableTxIns
   :: AlonzoEraOnwards era

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

@@ -40,6 +40,13 @@ instance Applicative (BuildTxWith BuildTx) where
   pure = BuildTxWith
   (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a)
 
+instance Semigroup a => Semigroup (BuildTxWith build a) where
+  ViewTx <> ViewTx = ViewTx
+  (BuildTxWith a) <> (BuildTxWith b) = BuildTxWith (a <> b)
+
+instance (Applicative (BuildTxWith build), Monoid a) => Monoid (BuildTxWith build a) where
+  mempty = pure mempty
+
 buildTxWithToMaybe :: BuildTxWith build a -> Maybe a
 buildTxWithToMaybe ViewTx = Nothing
 buildTxWithToMaybe (BuildTxWith a) = Just a

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

@@ -14,30 +14,43 @@
 {-# LANGUAGE TypeOperators #-}
 
 module Cardano.Api.Internal.Tx.Output
-  ( -- ** Transaction outputs
-    CtxTx
+  ( -- * Transaction outputs
+    TxOut (..)
+
+    -- ** Transaction output contexts
+  , CtxTx
   , CtxUTxO
-  , TxOut (..)
-  , TxOutValue (..)
-  , TxOutDatum (TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline)
   , toCtxUTxOTxOut
   , fromCtxUTxOTxOut
-  , lovelaceToTxOutValue
-  , prettyRenderTxOut
-  , txOutValueToLovelace
-  , txOutValueToValue
-  , parseHash
-  , TxOutInAnyEra (..)
-  , txOutInAnyEra
+
+    -- ** Ledger conversion functions for outputs
   , fromShelleyTxOut
   , toShelleyTxOut
   , toShelleyTxOutAny
   , convTxOuts
   , fromLedgerTxOuts
   , toByronTxOut
+  --  ** An Output Value
+  , TxOutValue (..)
+  , lovelaceToTxOutValue
+  , txOutValueToLovelace
+  , txOutValueToValue
+
+    -- ** Datum
+  , TxOutDatum (..)
   , binaryDataToScriptData
   , scriptDataToInlineDatum
+
+    -- ** Existential type over an era
+  , TxOutInAnyEra (..)
+  , txOutInAnyEra
+
+    -- ** Utilities
   , validateTxOuts
+  , parseHash
+  , prettyRenderTxOut
+
+    -- ** Error types
   , TxOutputError (..)
   )
 where
@@ -960,8 +973,6 @@ deriving instance Eq (TxOutDatum ctx era)
 
 deriving instance Show (TxOutDatum ctx era)
 
-{-# COMPLETE TxOutDatumNone, TxOutDatumHash, TxOutSupplementalDatum, TxOutDatumInline #-}
-
 toAlonzoTxOutDatumHash
   :: TxOutDatum ctx era -> StrictMaybe Plutus.DataHash
 toAlonzoTxOutDatumHash TxOutDatumNone = SNothing