Fix reference script support in ledger-constraints

IntersectMBO · Sep 22, 2022 · 64231ef · 64231ef
1 parent 4e74a13
commit 64231ef
Show file tree

Hide file tree

Showing 4 changed files with 93 additions and 34 deletions.
diff --git a/plutus-contract/test/Spec/Contract/TxConstraints.hs b/plutus-contract/test/Spec/Contract/TxConstraints.hs
@@ -83,6 +83,19 @@ tests = testGroup "contract tx constraints"
             void $ activateContract w1 mustReferenceOutputV2ConTest tag
             void $ Trace.waitNSlots 3
 
+    , checkPredicateOptions
+        (changeInitialWalletValue w1 (const $ Ada.adaValueOf 1000) defaultCheckOptions)
+        "mustSpendScriptOutputWithReference can be used on-chain to unlock funds in a PlutusV2 script"
+        -- TODO: 2nd tx fails because the emulator validation doesn't understand reference scripts,
+        -- Reenable following lines when the emulator validation has been removed
+        -- (walletFundsChange w1 (Ada.adaValueOf 0)
+        -- .&&. valueAtAddress mustReferenceOutputV2ValidatorAddress (== Ada.adaValueOf 0)
+        -- .&&. assertValidatedTransactionCount 2
+        (assertValidatedTransactionCountOfTotal 1 2
+        ) $ do
+            void $ activateContract w1 mustSpendScriptOutputWithReferenceV2ConTest tag
+            void $ Trace.waitNSlots 3
+
     -- Testing package plutus-tx-constraints
 
     , checkPredicate "Tx.Constraints.mustReferenceOutput fails when trying to unlock funds in a PlutusV1 script"
@@ -103,7 +116,7 @@ tests = testGroup "contract tx constraints"
 
     , checkPredicateOptions
         (changeInitialWalletValue w1 (const $ Ada.adaValueOf 1000) defaultCheckOptions)
-        "A reference script can be used to witness a PlutusV2 script"
+        "Tx.Constraints.mustSpendScriptOutputWithReference can be used on-chain to unlock funds in a PlutusV2 script"
         (walletFundsChange w1 (Ada.adaValueOf 0)
         .&&. valueAtAddress mustReferenceOutputV2ValidatorAddress (== Ada.adaValueOf 0)
         .&&. assertValidatedTransactionCount 2
@@ -254,6 +267,35 @@ get3 :: [a] -> (a, a, a)
 get3 (a:b:c:_) = (a, b, c)
 get3 _         = error "Spec.Contract.TxConstraints.get3: not enough inputs"
 
+mustSpendScriptOutputWithReferenceV2ConTest :: Contract () EmptySchema ContractError ()
+mustSpendScriptOutputWithReferenceV2ConTest = do
+
+    utxos <- ownUtxos
+    myAddr <- Con.ownAddress
+    let ((utxoRef, utxo), (utxoRefForBalance1, _), (utxoRefForBalance2, _)) = get3 $ Map.toList utxos
+        ValidatorHash vh = fromJust $ Addr.toValidatorHash mustReferenceOutputV2ValidatorAddress
+        lookups = TC.unspentOutputs utxos
+               <> TC.plutusV2OtherScript mustReferenceOutputV2Validator
+        tx = TC.mustPayToOtherScript (ValidatorHash vh) (Datum $ PlutusTx.toBuiltinData utxoRef) (Ada.adaValueOf 5)
+          <> TC.mustSpendPubKeyOutput utxoRefForBalance1
+          <> TC.mustPayToAddressWithReferenceScript
+                myAddr
+                (ScriptHash vh)
+                Nothing (Ada.adaValueOf 25)
+    mkTxConstraints @Void lookups tx >>= submitTxConfirmed
+
+    -- Trying to unlock the Ada in the script address
+    scriptUtxos <- utxosAt mustReferenceOutputV2ValidatorAddress
+    utxos' <- ownUtxos
+    let
+        scriptUtxo = fst . last . Map.toList $ scriptUtxos
+        refScriptUtxo = fst . head . filter (isJust . Tx._ciTxOutReferenceScript . snd) . Map.toList $ utxos'
+        lookups = TC.unspentOutputs (Map.singleton utxoRef utxo <> scriptUtxos <> utxos')
+        tx = TC.mustReferenceOutput utxoRef
+          <> TC.mustSpendScriptOutputWithReference scriptUtxo unitRedeemer refScriptUtxo
+          <> TC.mustSpendPubKeyOutput utxoRefForBalance2
+    mkTxConstraints @Any lookups tx >>= submitTxConfirmed
+
 mustSpendScriptOutputWithReferenceTxV2ConTest :: Contract () EmptySchema ContractError ()
 mustSpendScriptOutputWithReferenceTxV2ConTest = do
     let mkTx lookups constraints = either (error . show) id $ Tx.Constraints.mkTx @Any def lookups constraints

diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs
@@ -66,6 +66,7 @@ module Ledger.Constraints.OffChain(
     , updateUtxoIndex
     , lookupTxOutRef
     , lookupScript
+    , lookupScriptAsReferenceScript
     , resolveScriptTxOut
     , resolveScriptTxOutValidator
     , resolveScriptTxOutDatumAndValue
@@ -104,8 +105,8 @@ import Ledger.Crypto (pubKeyHash)
 import Ledger.Index (minAdaTxOut)
 import Ledger.Orphans ()
 import Ledger.Params (Params (pNetworkId))
-import Ledger.Tx (ChainIndexTxOut (_ciTxOutReferenceScript), Language (PlutusV1, PlutusV2), TxOut (TxOut), TxOutRef,
-                  Versioned (Versioned), outDatumHash, txOutValue)
+import Ledger.Tx (ChainIndexTxOut (_ciTxOutReferenceScript), Language (PlutusV1, PlutusV2), ReferenceScript,
+                  TxOut (TxOut), TxOutRef, Versioned (Versioned), outDatumHash, outReferenceScript, txOutValue)
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.CardanoAPI qualified as C
 import Ledger.Typed.Scripts (Any, ConnectionError (UnknownRef), TypedValidator,
@@ -515,7 +516,7 @@ updateUtxoIndex
 updateUtxoIndex = do
     ScriptLookups{slTxOutputs} <- ask
     networkId <- gets $ pNetworkId . cpsParams
-    slUtxos <- traverse (throwTxOutCardanoError . Tx.toTxOut networkId) slTxOutputs
+    slUtxos <- traverse (throwToCardanoError . Tx.toTxOut networkId) slTxOutputs
     unbalancedTx . utxoIndex <>= slUtxos
 
 -- | Add a typed input, checking the type of the output it spends. Return the value
@@ -571,7 +572,7 @@ addOwnOutput ScriptOutputConstraint{ocDatum, ocValue, ocReferenceScriptHash} = d
 
 data MkTxError =
     TypeCheckFailed Typed.ConnectionError
-    | TxOutCardanoError C.ToCardanoError
+    | ToCardanoError C.ToCardanoError
     | TxOutRefNotFound TxOutRef
     | TxOutRefWrongType TxOutRef
     | TxOutRefNoReferenceScript TxOutRef
@@ -590,7 +591,7 @@ data MkTxError =
 instance Pretty MkTxError where
     pretty = \case
         TypeCheckFailed e              -> "Type check failed:" <+> pretty e
-        TxOutCardanoError e            -> "Tx out cardano conversion error:" <+> pretty e
+        ToCardanoError e               -> "Cardano conversion error:" <+> pretty e
         TxOutRefNotFound t             -> "Tx out reference not found:" <+> pretty t
         TxOutRefWrongType t            -> "Tx out reference wrong type:" <+> pretty t
         TxOutRefNoReferenceScript t    -> "Tx out reference does not contain a reference script:" <+> pretty t
@@ -650,6 +651,16 @@ lookupScript sh =
     let err = throwError (ScriptHashNotFound sh) in
     asks slOtherScripts >>= maybe err pure . view (at sh)
 
+lookupScriptAsReferenceScript
+    :: ( MonadReader (ScriptLookups a) m
+       , MonadError MkTxError m
+       )
+    => Maybe ScriptHash
+    -> m ReferenceScript
+lookupScriptAsReferenceScript msh = do
+    mscript <- traverse lookupScript msh
+    throwToCardanoError $ C.toCardanoReferenceScript mscript
+
 -- | Modify the 'UnbalancedTx' so that it satisfies the constraints, if
 --   possible. Fails if a hash is missing from the lookups, or if an output
 --   of the wrong type is spent.
@@ -680,26 +691,23 @@ processConstraint = \case
           _ -> throwError (TxOutRefWrongType txo)
     MustSpendScriptOutput txo red mref -> do
         txout <- lookupTxOutRef txo
-        valOrRef <- case mref of
+        mDatumAndValue <- resolveScriptTxOutDatumAndValue txout
+        ((_, datum), value) <- maybe (throwError (TxOutRefWrongType txo)) pure mDatumAndValue
+        valueSpentInputs <>= provided value
+        case mref of
           Just ref -> do
             refTxOut <- lookupTxOutRef ref
             case _ciTxOutReferenceScript refTxOut of
-                Just val -> pure $ Tx.addReferenceTxInput txo (ref <$ val)
+                Just val -> do
+                    unbalancedTx . tx %= Tx.addReferenceTxInput txo (ref <$ val) red datum
+                    unbalancedTx . tx . Tx.referenceInputs <>= [Tx.pubKeyTxInput ref]
                 _        -> throwError (TxOutRefNoReferenceScript ref)
           Nothing -> do
             mscriptTXO <- resolveScriptTxOutValidator txout
             case mscriptTXO of
-                Just (_, val) -> pure $ Tx.addScriptTxInput txo val
+                Just (_, val) -> do
+                    unbalancedTx . tx %= Tx.addScriptTxInput txo val red datum
                 _             -> throwError (TxOutRefWrongType txo)
-        mDatumAndValue <- resolveScriptTxOutDatumAndValue txout
-        case mDatumAndValue of
-          Just ((_, datum), value) -> do
-            -- TODO: When witnesses are properly segregated we can
-            --       probably get rid of the 'slOtherData' map and of
-            --       'lookupDatum'
-            unbalancedTx . tx %= valOrRef red datum
-            valueSpentInputs <>= provided value
-          _ -> throwError (TxOutRefWrongType txo)
     MustUseOutputAsCollateral txo -> do
         unbalancedTx . tx . Tx.collateralInputs <>= [Tx.pubKeyTxInput txo]
     MustReferenceOutput txo -> do
@@ -719,8 +727,8 @@ processConstraint = \case
         unbalancedTx . tx . Tx.mintScripts %= Map.insert mpsHash red
         unbalancedTx . tx . Tx.scriptWitnesses %= Map.insert (ScriptHash mpsHashBytes) (fmap getMintingPolicy mintingPolicyScript)
         unbalancedTx . tx . Tx.mint <>= value i
-    MustPayToPubKeyAddress pk skhM mdv _refScript vl -> do
-        -- TODO: implement adding reference script
+    MustPayToPubKeyAddress pk skhM mdv refScriptHashM vl -> do
+        refScript <- lookupScriptAsReferenceScript refScriptHashM
         -- if datum is presented, add it to 'datumWitnesses'
         forM_ mdv $ \dv -> do
             unbalancedTx . tx . Tx.datumWitnesses . at (P.datumHash dv) ?= dv
@@ -729,18 +737,22 @@ processConstraint = \case
                                  , PV1.txOutDatumHash=Nothing
                                  }
         let txInDatum = C.toCardanoTxOutDatumInTx mdv
-        txOut <- toCardanoTxOutWithHashedDatum pv1TxOut <&> outDatumHash .~ txInDatum
+        txOut <- toCardanoTxOutWithHashedDatum pv1TxOut
+            <&> outDatumHash .~ txInDatum
+            <&> outReferenceScript .~ refScript
         unbalancedTx . tx . Tx.outputs %= (txOut :)
         valueSpentOutputs <>= provided vl
-    MustPayToOtherScript vlh svhM dv _refScript vl -> do
-        -- TODO: implement adding reference script
+    MustPayToOtherScript vlh svhM dv refScriptHashM vl -> do
+        refScript <- lookupScriptAsReferenceScript refScriptHashM
         let addr = Address.scriptValidatorHashAddress vlh svhM
             theHash = P.datumHash dv
             pv1script = scriptAddressTxOut addr vl dv
         unbalancedTx . tx . Tx.datumWitnesses . at theHash ?= dv
 
         let txInDatum = C.toCardanoTxOutDatumInTx (Just dv)
-        txScript <- toCardanoTxOutWithHashedDatum pv1script <&> outDatumHash .~ txInDatum
+        txScript <- toCardanoTxOutWithHashedDatum pv1script
+            <&> outDatumHash .~ txInDatum
+            <&> outReferenceScript .~ refScript
         unbalancedTx . tx . Tx.outputs %= (txScript :)
         valueSpentOutputs <>= provided vl
     MustHashDatum dvh dv -> do
@@ -828,8 +840,8 @@ toCardanoTxOutWithHashedDatum
   => PV1.TxOut -> m TxOut
 toCardanoTxOutWithHashedDatum txout = do
   networkId <- gets $ pNetworkId . cpsParams
-  throwTxOutCardanoError $ TxOut <$> C.toCardanoTxOut networkId C.toCardanoTxOutDatumHash txout
+  throwToCardanoError $ TxOut <$> C.toCardanoTxOut networkId C.toCardanoTxOutDatumHash txout
 
-throwTxOutCardanoError :: MonadError MkTxError m => Either C.ToCardanoError a -> m a
-throwTxOutCardanoError (Left err) = throwError $ TxOutCardanoError err
-throwTxOutCardanoError (Right a)  = pure a
+throwToCardanoError :: MonadError MkTxError m => Either C.ToCardanoError a -> m a
+throwToCardanoError (Left err) = throwError $ ToCardanoError err
+throwToCardanoError (Right a)  = pure a
diff --git a/plutus-ledger/src/Ledger/Tx/Internal.hs b/plutus-ledger/src/Ledger/Tx/Internal.hs
@@ -455,6 +455,16 @@ outDatumHash = L.lens
   txOutDatumHash
   (\(TxOut (C.TxOut aie tov _ rs)) tod -> TxOut (C.TxOut aie tov tod rs))
 
+type ReferenceScript = C.ReferenceScript C.BabbageEra
+
+txOutReferenceScript :: TxOut -> ReferenceScript
+txOutReferenceScript (TxOut (C.TxOut _aie _tov _tod rs)) = rs
+
+outReferenceScript :: L.Lens' TxOut ReferenceScript
+outReferenceScript = L.lens
+  txOutReferenceScript
+  (\(TxOut (C.TxOut aie tov tod _)) rs -> TxOut (C.TxOut aie tov tod rs))
+
 lookupScript :: Map ScriptHash (Versioned Script) -> ScriptHash -> Maybe (Versioned Script)
 lookupScript txScripts hash  = Map.lookup hash txScripts
 

diff --git a/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs b/plutus-tx-constraints/src/Ledger/Tx/Constraints/OffChain.hs
@@ -74,7 +74,6 @@ import Ledger.Orphans ()
 import Ledger.Scripts (ScriptHash, getDatum, getRedeemer, getValidator)
 import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange)
 import Ledger.Tx qualified as Tx
-import Ledger.Tx.CardanoAPI (toCardanoScriptInAnyLang)
 import Ledger.Tx.CardanoAPI qualified as C
 import Ledger.Typed.Scripts (ValidatorTypes (DatumType, RedeemerType))
 import PlutusTx (FromData, ToData)
@@ -316,11 +315,7 @@ lookupTxOutRef txo = mapLedgerMkTxError $ P.lookupTxOutRef txo
 lookupScriptAsReferenceScript
     :: Maybe ScriptHash
     -> ReaderT (P.ScriptLookups a) (StateT P.ConstraintProcessingState (Except MkTxError)) (C.ReferenceScript C.BabbageEra)
-lookupScriptAsReferenceScript Nothing = pure C.ReferenceScriptNone
-lookupScriptAsReferenceScript (Just sh) = do
-    script <- mapLedgerMkTxError $ P.lookupScript sh
-    scriptInAnyLang <- either (throwError . ToCardanoError) pure $ toCardanoScriptInAnyLang script
-    pure $ C.ReferenceScript C.ReferenceTxInsScriptsInlineDatumsInBabbageEra scriptInAnyLang
+lookupScriptAsReferenceScript msh = mapLedgerMkTxError $ P.lookupScriptAsReferenceScript msh
 
 addOwnOutput
     :: ToData (DatumType a)