diff --git a/bitte/static-site.nix b/bitte/static-site.nix index 78e6da4ba2..275c92c4cb 100644 --- a/bitte/static-site.nix +++ b/bitte/static-site.nix @@ -15,11 +15,11 @@ let ".jpg" => "image/jpeg", ".jpeg" => "image/jpeg", ".html" => "text/html", - ".js" => "text/javascript", - ".svg" => "image/svg+xml", + ".js" => "text/javascript", + ".svg" => "image/svg+xml", ) - deflate.cache-dir = "/tmp" - deflate.mimetypes = ("text/plain", "text/html", "text/css") + deflate.cache-dir = "/tmp" + deflate.mimetypes = ("text/plain", "text/html", "text/css") server.upload-dirs = ("/tmp") ''; in diff --git a/cabal.project b/cabal.project index 2d20c78f6e..f1c417bcca 100644 --- a/cabal.project +++ b/cabal.project @@ -117,13 +117,6 @@ source-repository-package location: https://github.com/input-output-hk/purescript-bridge tag: 47a1f11825a0f9445e0f98792f79172efef66c00 --- Direct dependency. --- Temporary indexing -source-repository-package - type: git - location: https://github.com/raduom/hysterical-screams - tag: 4c523469e9efd3f0d10d17da3304923b7b0e0674 - -- Direct dependency. source-repository-package type: git diff --git a/doc/adr/0006-common-contract-api.rst b/doc/adr/0006-common-contract-api.rst new file mode 100644 index 0000000000..e704f11eaf --- /dev/null +++ b/doc/adr/0006-common-contract-api.rst @@ -0,0 +1,83 @@ +.. _common_pab_api: + +ADR 6: Common Contract API +========================== + +Date: 2022-07-12 + +Authors +------- + +Gergely Szabo + +koslambrou + +Status +------ + +Proposed + +Context +------- + +There are multiple implementations of a Plutus Application Backend (PAB) external of IO Global, and also other tools related to Plutus smart contracts. +Some of them are using the same contract interface as the official implementation, but some of them use a different interface. +However, as the ecosystem evolves, it would be beneficial to create a well defined standard, that other off-chain tools can use as a reference, or as an interface to implement. + +Currently, as we are getting close to the Vasil hardfork, testing tools and Plutus Application backend tools are at a hurry to update their dependencies and get to a Vasil compliant/compatible state. +However, tools that are depending on `plutus-apps` are blocked by the PAB development. +This initiative was born out of this context, but could solve other problems as well. + +The Contract API (defined in `plutus-apps/plutus-contract`) is using the `freer-simple` effect system to define all the contract effects. +This already allows us to separate the interface from the implementation, and to have multiple implementations/interpreters for one interface. +Currently, there are two implementations for the Contract API: + +* one for the plutus-apps emulator (inside `plutus-apps/plutus-contract`) +* one for plutus-apps' Plutus Application Backend (inside `plutus-apps/plutus-pab`) + +Therefore, we can leverage this separatation of interface and implementation in order to move the interface out of `plutus-apps`. + +Decision +-------- + +* We will split the `plutus-apps/plutus-contract` package into two parts: the Contract API (`plutus-contract`) and the emulator (`plutus-contract-emulator`). + +* We will create effects for the constraints-based transaction builder library (`plutus-apps/plutus-ledger-constraints`) in the Contract API. + Currently, the interface and the implementation in the transaction builder library are tightly coupled. + Therefore, we need to decouple them. + +* We will create a separate repository with the contract effects and types (the splitted `plutus-contract`). + By moving the Contract API out of the plutus-apps monorepository, any tool could update to newer version to their discretion. + Without many dependencies, many tools could utilize the Contract API without having to depend on the whole plutus-apps monorepo. + +* We (the Plutus Tools at IO Global) will continue to be the main maintainers of this new repository. + However, a new ADR will need to be created if we ever decide to make this a community driven project. + +* TODO: What about governance? How do we decide which interface changes are accepted? ADRs? Who ultimately accepts and rejects them? + +Argument +-------- + +We speed up the development of off-chain tools, by loosening up some of tightly coupled dependencies, so these external projects can move more freely. +This would also mean that the cost of the interface update would be reduced, so we could see more features added to the standard, and the PAB API following the capabilities of Cardano more closely. +As an added benefit, community involvement with the API could also greatly improve. + +A standard API for all Plutus contacts would help keeping the ecosystem on the same track with their implementation. +As more and more off-chain tools implement the same contract interface in the future, it will be relatively easy to switch between different Plutus Application Backend implementations, or to use multiple of these tools at the same time without a need for serious code rewrites. + +The implementation of the Contract API interface would track a specific version of the Contract API interface. +We would then need to regularly update the implementation given any interface changes. + +Implications +------------ + +* We will need to decide if we should make this a community driven project. + If so, we will also need to make a decision about governance. + How do we decide which interface changes are accepted? + Do we use ADRs? + Who ultimately accepts and rejects them? + +Notes +----- + +This ADR has been discussed here: `#586 `_. diff --git a/doc/adr/0007-support-reference-inputs-in-constraint-library.rst b/doc/adr/0007-support-reference-inputs-in-constraint-library.rst new file mode 100644 index 0000000000..d066dfa47f --- /dev/null +++ b/doc/adr/0007-support-reference-inputs-in-constraint-library.rst @@ -0,0 +1,47 @@ +.. _support_reference_inputs_in_constraint_library: + +ADR 7: Support reference inputs in constraint library +===================================================== + +Date: 2022-08-09 + +Authors +------- + +koslambrou + +Status +------ + +Proposed + +Context +------- + +After the Vasil HF, the Cardano blockchain will support `reference` inputs by adding a new field in the transaction data type. +With reference inputs, transactions can take a look at UTXOs without actually spending them. + +Thus, we need to adapt our transaction constraint data type (`TxConstraints`) to support referencing UTXOs. + +Decision +-------- + +* We will add the data constuctor `MustReferenceOutput TxOutRef` to the `TxConstraints` data type. + +* The PlutusV1 on-chain implementation of this new constraint will simply return `False`. + However, `cardano-ledger` throws a phase-1 validation error if transactions that use the some of the new features (reference inputs, inline datums and reference scripts) try to execute PlutusV1 scripts. + See the `Babbage era ledger specification `_. + Therefore, the only way to get a phase-2 validation error would be to use this constraint on-chain in a PlutusV1 script, without using any of the new Babbage era features off-chain. + +* The PlutusV2 on-chain implementation of this new constraint will check that the provided `TxOutRef` is part of the `ScriptContext`'s reference inputs. + +Argument +-------- + +At first glance, we might think that we need two data constructors for reference inputs such as `MustReferencePubKeyOutput` and `MustReferenceScriptOutput` in contrast to the existing `MustSpendPubKeyOutput` and `MustSpendScriptOutput` constraints. +However, we do not need to make the distinction between public key outputs and script outputs because we're not spending the output, therefore, we don't need to provide a redeemer nor the actual script as a witness to the transaction input. + +Notes +----- + +This ADR has been partially addressed on PR `#640 `_. diff --git a/doc/adr/index.rst b/doc/adr/index.rst index 0bfd4fb84f..5b7a3a138a 100644 --- a/doc/adr/index.rst +++ b/doc/adr/index.rst @@ -35,3 +35,5 @@ The general process for creating an ADR is: 0003-marconi-monorepo 0004-marconi-initiative 0005-pab-indexing-solution-integration + 0006-common-contract-api + 0007-support-reference-inputs-in-constraint-library diff --git a/nix/pkgs/haskell/sha256map.nix b/nix/pkgs/haskell/sha256map.nix index f484bf5b6c..ad68afbc9f 100644 --- a/nix/pkgs/haskell/sha256map.nix +++ b/nix/pkgs/haskell/sha256map.nix @@ -21,7 +21,6 @@ "https://github.com/input-output-hk/servant-purescript"."44e7cacf109f84984cd99cd3faf185d161826963" = "10pb0yfp80jhb9ryn65a4rha2lxzsn2vlhcc6xphrrkf4x5lhzqc"; "https://github.com/input-output-hk/typed-protocols"."181601bc3d9e9d21a671ce01e0b481348b3ca104" = "sha256-5Wof5yTKb12EPY6B8LfapX18xNZZpF+rvhnQ88U6KdM="; "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx"; - "https://github.com/raduom/hysterical-screams"."4c523469e9efd3f0d10d17da3304923b7b0e0674" = "0w118v4vffrsjxfmwfv8qcn2qxmxpd1gxwcjnda91qz09jnpg0vp"; "https://github.com/sevanspowell/hw-aeson"."b5ef03a7d7443fcd6217ed88c335f0c411a05408" = "1dwx90wqavdl4d0npbzbxyh2pzi9zs1qz7nvsrb3n1cm2xbv4i5z"; "https://github.com/vshabanov/ekg-json"."00ebe7211c981686e65730b7144fbf5350462608" = "sha256-VT8Ur585TCn03P2TVi6t92v2Z6tl8vKijICjse6ocv8="; } diff --git a/plutus-chain-index/app/Marconi.hs b/plutus-chain-index/app/Marconi.hs index ee3040cd47..9a9d6cab9d 100644 --- a/plutus-chain-index/app/Marconi.hs +++ b/plutus-chain-index/app/Marconi.hs @@ -28,7 +28,6 @@ import Data.Proxy (Proxy (Proxy)) import Data.Set (Set) import Data.Set qualified as Set import Data.String (IsString) -import Index.VSplit qualified as Ix import Ledger (TxIn (..), TxOut (..), TxOutRef (..)) import Ledger.Tx.CardanoAPI (fromCardanoTxId, fromCardanoTxIn, fromCardanoTxOut, fromTxScriptValidity, scriptDataFromCardanoTxBody) @@ -39,6 +38,7 @@ import Marconi.Index.Utxo qualified as Utxo import Marconi.Logging (logging) import Options.Applicative (Mod, OptionFields, Parser, auto, execParser, flag', help, helper, info, long, maybeReader, metavar, option, readerError, strOption, (<**>), (<|>)) +import Plutus.HystericalScreams.Index.VSplit qualified as Ix import Plutus.Streaming (ChainSyncEvent (RollBackward, RollForward), ChainSyncEventException (NoIntersectionFound), withChainSyncEventStream) import Plutus.V1.Ledger.Api (Datum, DatumHash) diff --git a/plutus-chain-index/app/Marconi/Index/Datum.hs b/plutus-chain-index/app/Marconi/Index/Datum.hs index f8fedaa182..e2760d39c8 100644 --- a/plutus-chain-index/app/Marconi/Index/Datum.hs +++ b/plutus-chain-index/app/Marconi/Index/Datum.hs @@ -26,9 +26,9 @@ import Database.SQLite.Simple.FromField (FromField (fromField), ResultError (Con import Database.SQLite.Simple.ToField (ToField (toField)) import Cardano.Api (SlotNo (SlotNo)) -import Index.VSqlite (SqliteIndex) -import Index.VSqlite qualified as Ix import Ledger.Scripts (Datum, DatumHash) +import Plutus.HystericalScreams.Index.VSqlite (SqliteIndex) +import Plutus.HystericalScreams.Index.VSqlite qualified as Ix type Event = [(SlotNo, (DatumHash, Datum))] type Query = DatumHash diff --git a/plutus-chain-index/app/Marconi/Index/Utxo.hs b/plutus-chain-index/app/Marconi/Index/Utxo.hs index c93886237f..8931c63418 100644 --- a/plutus-chain-index/app/Marconi/Index/Utxo.hs +++ b/plutus-chain-index/app/Marconi/Index/Utxo.hs @@ -42,8 +42,8 @@ import Ledger (Address, TxId, TxOut, TxOutRef (TxOutRef, txOutRefId, txOutRefIdx import Ledger qualified as Ledger import System.Random.MWC (createSystemRandom, uniformR) -import Index.VSqlite (SqliteIndex) -import Index.VSqlite qualified as Ix +import Plutus.HystericalScreams.Index.VSqlite (SqliteIndex) +import Plutus.HystericalScreams.Index.VSqlite qualified as Ix data UtxoUpdate = UtxoUpdate { _inputs :: !(Set TxOutRef) diff --git a/plutus-chain-index/plutus-chain-index.cabal b/plutus-chain-index/plutus-chain-index.cabal index b90d439f1f..77f6cab0c5 100644 --- a/plutus-chain-index/plutus-chain-index.cabal +++ b/plutus-chain-index/plutus-chain-index.cabal @@ -126,9 +126,9 @@ executable marconi -- Local components -------------------- build-depends: - , hysterical-screams - , plutus-ledger >=1.0.0 - , plutus-streaming >=1.0.0 + , plutus-hysterical-screams + , plutus-ledger >=1.0.0 + , plutus-streaming >=1.0.0 -------------------------- -- Other IOG dependencies diff --git a/plutus-contract/plutus-contract.cabal b/plutus-contract/plutus-contract.cabal index 6b1eb0ed80..1f4e9f4955 100644 --- a/plutus-contract/plutus-contract.cabal +++ b/plutus-contract/plutus-contract.cabal @@ -243,7 +243,9 @@ test-suite plutus-contract-test Spec.Secrets Spec.State Spec.ThreadToken - Spec.TimeValidity + Spec.TxConstraints.MustSpendAtLeast + Spec.TxConstraints.RequiredSigner + Spec.TxConstraints.TimeValidity -------------------- -- Local components diff --git a/plutus-contract/src/Wallet/Emulator/Chain.hs b/plutus-contract/src/Wallet/Emulator/Chain.hs index bcbe804ee4..f3621f981f 100644 --- a/plutus-contract/src/Wallet/Emulator/Chain.hs +++ b/plutus-contract/src/Wallet/Emulator/Chain.hs @@ -205,7 +205,7 @@ validateEm h cUtxoIndex txn = do let (e, events) = txn & mergeCardanoTxWith (\tx -> Index.runValidation (Index.validateTransaction h tx) ctx) (\tx -> validateL params h cUtxoIndex tx) - (\(e1, sve1) (e2, sve2) -> (e1 <|> e2, sve1 ++ sve2)) + (\(e1, sve1) (e2, sve2) -> (e2 <|> e1, sve2 ++ sve1)) idx' = case e of Just (Index.Phase1, _) -> idx Just (Index.Phase2, _) -> Index.insertCollateral txn idx diff --git a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs index 49fe06556a..c95d0eec98 100644 --- a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs +++ b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs @@ -38,6 +38,7 @@ import Ledger hiding (to, value) import Ledger.Ada qualified as Ada import Ledger.AddressMap qualified as AM import Ledger.Index qualified as Index +import Ledger.Value qualified as Value import Plutus.ChainIndex.Emulator qualified as ChainIndex import Plutus.Contract.Error (AssertionError (GenericAssertion)) import Plutus.Trace.Emulator.Types (ContractInstanceLog, EmulatedWalletEffects, EmulatedWalletEffects', UserThreadMsg) @@ -303,12 +304,13 @@ emulatorStateInitialDist mp = emulatorStatePool [EmulatorTx tx] where , txData = mempty } -- See [Creating wallets with multiple outputs] - mkOutputs (key, vl) = mkOutput key <$> splitHeadinto10 (Wallet.splitOffAdaOnlyValue vl) - splitHeadinto10 [] = [] - splitHeadinto10 (vl:vls) = replicate (fromIntegral count) (Ada.toValue . (`div` count) . Ada.fromValue $ vl) ++ vls + mkOutputs (key, vl) = mkOutput key <$> splitInto10 vl + splitInto10 vl = replicate (fromIntegral count) (Ada.toValue (ada `div` count)) ++ remainder where + ada = if Value.isAdaOnlyValue vl then Ada.fromValue vl else Ada.fromValue vl - minAdaTxOut -- Make sure we don't make the outputs too small - count = min 10 $ Ada.fromValue vl `div` minAdaTxOut + count = min 10 $ ada `div` minAdaTxOut + remainder = [ vl <> Ada.toValue (-ada) | not (Value.isAdaOnlyValue vl) ] mkOutput key vl = pubKeyHashTxOut vl (unPaymentPubKeyHash key) type MultiAgentEffs = diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs index ade7b16671..c19438a27d 100644 --- a/plutus-contract/src/Wallet/Emulator/Wallet.hs +++ b/plutus-contract/src/Wallet/Emulator/Wallet.hs @@ -16,6 +16,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -34,31 +35,31 @@ import Control.Monad.Freer.TH (makeEffect) import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), ToJSONKey) import Data.Aeson qualified as Aeson import Data.Bifunctor (bimap, first, second) -import Data.Data +import Data.Data (Data) import Data.Default (Default (def)) import Data.Foldable (Foldable (fold), find, foldl') -import Data.List (sort) +import Data.List (sort, sortOn, (\\)) import Data.Map qualified as Map import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe) import Data.OpenApi.Schema qualified as OpenApi +import Data.Ord (Down (Down)) import Data.Set qualified as Set import Data.String (IsString (fromString)) import Data.Text qualified as T import Data.Text.Class (fromText, toText) import GHC.Generics (Generic) -import Ledger (Address (addressCredential), CardanoTx, ChainIndexTxOut, Params (..), - PaymentPrivateKey (PaymentPrivateKey, unPaymentPrivateKey), - PaymentPubKey (PaymentPubKey, unPaymentPubKey), - PaymentPubKeyHash (PaymentPubKeyHash, unPaymentPubKeyHash), SomeCardanoApiTx, StakePubKey, - Tx (txFee, txMint), UtxoIndex (..)) -import Ledger qualified import Ledger.Ada qualified as Ada +import Ledger.Address (Address (addressCredential), PaymentPrivateKey (..), PaymentPubKey, + PaymentPubKeyHash (PaymentPubKeyHash)) import Ledger.CardanoWallet (MockWallet, WalletNumber) import Ledger.CardanoWallet qualified as CW import Ledger.Constraints.OffChain (UnbalancedTx) import Ledger.Constraints.OffChain qualified as U import Ledger.Credential (Credential (PubKeyCredential, ScriptCredential)) import Ledger.Fee (estimateTransactionFee, makeAutoBalancedTransaction) +import Ledger.Index (UtxoIndex (UtxoIndex, getIndex)) +import Ledger.Params (Params (Params, pProtocolParams, pSlotConfig)) +import Ledger.Tx (CardanoTx, ChainIndexTxOut, SomeCardanoApiTx, Tx (txFee, txMint), TxIn, TxOut (TxOut)) import Ledger.Tx qualified as Tx import Ledger.Tx.CardanoAPI (makeTransactionBody) import Ledger.Validation (addSignature, fromPlutusIndex, fromPlutusTx, getRequiredSigners) @@ -67,17 +68,20 @@ import Plutus.ChainIndex (PageQuery) import Plutus.ChainIndex qualified as ChainIndex import Plutus.ChainIndex.Api (UtxosResponse (page)) import Plutus.ChainIndex.Emulator (ChainIndexEmulatorState, ChainIndexQueryEffect) -import Plutus.Contract (WalletAPIError) import Plutus.Contract.Checkpoint (CheckpointLogMsg) import Plutus.Contract.Wallet (finalize) import Plutus.V1.Ledger.Api (PubKeyHash, TxOutRef, ValidatorHash, Value) import PlutusTx.Prelude qualified as PlutusTx import Prettyprinter (Pretty (pretty)) import Servant.API (FromHttpApiData (parseUrlPiece), ToHttpApiData (toUrlPiece)) -import Wallet.API qualified as WAPI +import Wallet.API (WalletAPIError) +import Wallet.Effects qualified as WAPI (getClientParams) +import Wallet.Error qualified as WAPI (WalletAPIError (InsufficientFunds, PaymentPrivateKeyNotFound, ToCardanoError, ValidationError), + throwOtherError) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty +import Ledger qualified import Wallet.Effects (NodeClientEffect, WalletEffect (BalanceTx, OwnAddresses, SubmitTxn, TotalFunds, WalletAddSignature, YieldUnbalancedTx), publishTx) @@ -165,26 +169,25 @@ walletToMockWallet :: Wallet -> Maybe MockWallet walletToMockWallet (Wallet _ wid) = find ((==) wid . WalletId . Cardano.Wallet.WalletId . CW.mwWalletId) CW.knownMockWallets --- | The public key of a mock wallet. (Fails if the wallet is not a mock wallet). -mockWalletPaymentPubKey :: Wallet -> PaymentPubKey -mockWalletPaymentPubKey w = - CW.paymentPubKey - $ fromMaybe (error $ "Wallet.Emulator.Wallet.walletPubKey: Wallet " +-- | The same as @walletToMockWallet@ but fails with an error instead of returning @Nothing@. +walletToMockWallet' :: Wallet -> MockWallet +walletToMockWallet' w = + fromMaybe (error $ "Wallet.Emulator.Wallet.walletToMockWallet': Wallet " <> show w <> " is not a mock wallet") - $ walletToMockWallet w + $ walletToMockWallet w + +-- | The public key of a mock wallet. (Fails if the wallet is not a mock wallet). +mockWalletPaymentPubKey :: Wallet -> PaymentPubKey +mockWalletPaymentPubKey = CW.paymentPubKey . walletToMockWallet' -- | The payment public key hash of a mock wallet. (Fails if the wallet is not a mock wallet). mockWalletPaymentPubKeyHash :: Wallet -> PaymentPubKeyHash -mockWalletPaymentPubKeyHash = - PaymentPubKeyHash - . Ledger.pubKeyHash - . unPaymentPubKey - . mockWalletPaymentPubKey +mockWalletPaymentPubKeyHash = CW.paymentPubKeyHash . walletToMockWallet' -- | Get the address of a mock wallet. (Fails if the wallet is not a mock wallet). mockWalletAddress :: Wallet -> Address -mockWalletAddress w = Ledger.pubKeyHashAddress (mockWalletPaymentPubKeyHash w) Nothing +mockWalletAddress = CW.mockWalletAddress . walletToMockWallet' data WalletEvent = GenericLog T.Text @@ -223,11 +226,7 @@ ownPaymentPublicKey = CW.paymentPubKey . _mockWallet -- | Get the user's own payment public-key address. ownAddress :: WalletState -> Address -ownAddress = flip Ledger.pubKeyAddress Nothing - . PaymentPubKey - . Ledger.toPublicKey - . unPaymentPrivateKey - . ownPaymentPrivateKey +ownAddress = flip Ledger.pubKeyAddress Nothing . ownPaymentPublicKey -- | An empty wallet using the given private key. -- for that wallet as the sole watched address. @@ -342,8 +341,8 @@ handleBalance utx' = do cTx <- handleError (Right tx) $ fromPlutusTx params cUtxoIndex requiredSigners tx pure $ Tx.Both tx (Tx.CardanoApiEmulatorEraTx cTx) Left txBodyContent -> do - ownPaymentPubKey <- gets ownPaymentPublicKey - cTx <- handleError eitherTx $ makeAutoBalancedTransaction params cUtxoIndex txBodyContent (Ledger.pubKeyAddress ownPaymentPubKey Nothing) + ownAddr <- gets ownAddress + cTx <- handleError eitherTx $ makeAutoBalancedTransaction params cUtxoIndex txBodyContent ownAddr pure $ Tx.CardanoApiTx (Tx.CardanoApiEmulatorEraTx cTx) where handleError tx (Left (Left (ph, ve))) = do @@ -396,14 +395,14 @@ ownOutputs WalletState{_mockWallet} = do refs <- allUtxoSet (Just def) Map.fromList . catMaybes <$> traverse txOutRefTxOutFromRef refs where - cred :: Credential - cred = PubKeyCredential (unPaymentPubKeyHash $ CW.paymentPubKeyHash _mockWallet) + addr :: Address + addr = CW.mockWalletAddress _mockWallet -- Accumulate all unspent 'TxOutRef's from the resulting pages. allUtxoSet :: Maybe (PageQuery TxOutRef) -> Eff effs [TxOutRef] allUtxoSet Nothing = pure [] allUtxoSet (Just pq) = do - refPage <- page <$> ChainIndex.utxoSetAtAddress pq cred + refPage <- page <$> ChainIndex.utxoSetAtAddress pq (addressCredential addr) nextItems <- allUtxoSet (ChainIndex.nextPageQuery refPage) pure $ ChainIndex.pageItems refPage ++ nextItems @@ -436,11 +435,10 @@ handleBalanceTx :: -> UnbalancedTx -> Eff effs Tx handleBalanceTx utxo utx = do - Params { pProtocolParams } <- WAPI.getClientParams + params@Params { pProtocolParams } <- WAPI.getClientParams let filteredUnbalancedTxTx = removeEmptyOutputs (view U.tx utx) let txInputs = Tx.txInputs filteredUnbalancedTxTx - ownPaymentPubKey <- gets ownPaymentPublicKey - let ownStakePubKey = Nothing + ownAddr <- gets ownAddress inputValues <- traverse lookupValue (Tx.txInputs filteredUnbalancedTxTx) collateral <- traverse lookupValue (Tx.txCollateral filteredUnbalancedTxTx) let fees = txFee filteredUnbalancedTxTx @@ -449,7 +447,13 @@ handleBalanceTx utxo utx = do collFees = Ada.toValue $ (Ada.fromValue fees * maybe 100 fromIntegral (protocolParamCollateralPercent pProtocolParams)) `Ada.divide` 100 remainingCollFees = collFees PlutusTx.- fold collateral balance = left PlutusTx.- right - (neg, pos) = adjustBalanceWithMissingLovelace $ Value.split balance + -- filter out inputs from utxo that are already in unBalancedTx + inputsOutRefs = map Tx.txInRef txInputs + filteredUtxo = flip Map.filterWithKey utxo $ \txOutRef _ -> + txOutRef `notElem` inputsOutRefs + outRefsWithValue = second (view Ledger.ciTxOutValue) <$> Map.toList filteredUtxo + + ((neg, newTxIns), (pos, newTxOuts)) <- calculateTxChanges params ownAddr outRefsWithValue $ Value.split balance tx' <- if Value.isZero pos then do @@ -457,7 +461,7 @@ handleBalanceTx utxo utx = do pure filteredUnbalancedTxTx else do logDebug $ AddingPublicKeyOutputFor pos - pure $ addOutput ownPaymentPubKey ownStakePubKey pos filteredUnbalancedTxTx + pure $ filteredUnbalancedTxTx & over Tx.outputs (++ newTxOuts) tx'' <- if Value.isZero neg then do @@ -465,11 +469,7 @@ handleBalanceTx utxo utx = do pure tx' else do logDebug $ AddingInputsFor neg - -- filter out inputs from utxo that are already in unBalancedTx - let inputsOutRefs = map Tx.txInRef txInputs - filteredUtxo = flip Map.filterWithKey utxo $ \txOutRef _ -> - txOutRef `notElem` inputsOutRefs - addInputs filteredUtxo ownPaymentPubKey ownStakePubKey neg tx' + pure $ tx' & over Tx.inputs (sort . (++) newTxIns) if remainingCollFees `Value.leq` PlutusTx.zero then do @@ -479,36 +479,45 @@ handleBalanceTx utxo utx = do logDebug $ AddingCollateralInputsFor remainingCollFees addCollateral utxo remainingCollFees tx'' --- | Adjust the left and right balance of an unbalanced 'Tx' with the missing --- lovelace considering the minimum lovelace per transaction output constraint --- from the Cardano blockchain. -adjustBalanceWithMissingLovelace - :: (Value, Value) -- ^ The unbalanced tx's left and right balance. - -> (Value, Value) -- ^ New left and right balance. -adjustBalanceWithMissingLovelace (neg, pos) = do - - -- We find the missing lovelace from the new positive balance. If - -- the positive balance is > 0 and < 'Ledger.minAdaTxOut', - -- then we adjust it to the minimum Ada. - let missingLovelaceFromPosValue = - if valueIsZeroOrHasMinAda pos - then 0 - else max 0 (Ledger.minAdaTxOut - Ada.fromValue pos) - -- We calculate the final negative and positive balances - newPos = pos <> Ada.toValue missingLovelaceFromPosValue - newNeg = neg <> Ada.toValue missingLovelaceFromPosValue - - (newNeg, newPos) - --- | Split value into an ada-only and an non-ada-only value, making sure each has at least minAdaTxOut. -splitOffAdaOnlyValue :: Value -> [Value] -splitOffAdaOnlyValue vl = if Value.isAdaOnlyValue vl || ada < Ledger.minAdaTxOut then [vl] else [Ada.toValue ada, vl <> Ada.toValue (-ada)] - where - ada = Ada.fromValue vl - Ledger.minAdaTxOut - -addOutput :: PaymentPubKey -> Maybe StakePubKey -> Value -> Tx -> Tx -addOutput pk sk vl tx = tx & over Tx.outputs (++ pkos) where - pkos = (\v -> Tx.pubKeyTxOut v pk sk) <$> splitOffAdaOnlyValue vl +calculateTxChanges + :: ( Member (Error WAPI.WalletAPIError) effs + ) + => Params + -> Address -- ^ The address for the change output + -> [(TxOutRef, Value)] -- ^ The current wallet's unspent transaction outputs. + -> (Value, Value) -- ^ The unbalanced tx's negative and positive balance. + -> Eff effs ((Value, [TxIn]), (Value, [TxOut])) +calculateTxChanges params addr utxos (neg, pos) = do + + -- Calculate the change output with minimal ada + (newNeg, newPos, extraTxOuts) <- if Value.isZero pos + then pure (neg, pos, []) + else do + (missing, extraTxOut) <- + either (throwError . WAPI.ToCardanoError) pure + $ U.adjustTxOut params (TxOut addr pos Nothing) + let missingValue = Ada.toValue (fold missing) + -- Add the missing ada to both sides to keep the balance. + pure (neg <> missingValue, pos <> missingValue, [extraTxOut]) + + -- Calculate the extra inputs needed + (spend, change) <- if Value.isZero newNeg + then pure ([], mempty) + else selectCoin utxos newNeg + + if Value.isZero change + then do + -- No change, so the new inputs and outputs have balanced the transaction + pure ((newNeg, Tx.pubKeyTxIn . fst <$> spend), (newPos, extraTxOuts)) + else if null extraTxOuts + -- We have change so we need an extra output, if we didn't have that yet, + -- first make one with an estimated minimal amount of ada + -- which then will calculate a more exact set of inputs + then calculateTxChanges params addr utxos (neg <> Ada.toValue Ledger.minAdaTxOut, Ada.toValue Ledger.minAdaTxOut) + -- Else recalculate with the change added to both sides + -- Ideally this creates the same inputs and outputs and then the change will be zero + -- But possibly the minimal Ada increases and then we also want to compute a new set of inputs + else calculateTxChanges params addr utxos (newNeg <> change, newPos <> change) addCollateral :: ( Member (Error WAPI.WalletAPIError) effs @@ -524,41 +533,15 @@ addCollateral mp vl tx = do in over Tx.collateralInputs (sort . (++) ins) pure $ tx & addTxCollateral --- | @addInputs mp pk vl tx@ selects transaction outputs worth at least --- @vl@ from the UTXO map @mp@ and adds them as inputs to @tx@. A public --- key output for @pk@ is added containing any leftover change. -addInputs - :: ( Member (Error WAPI.WalletAPIError) effs - ) - => Map.Map TxOutRef ChainIndexTxOut -- ^ The current wallet's unspent transaction outputs. - -> PaymentPubKey - -> Maybe StakePubKey - -> Value - -> Tx - -> Eff effs Tx -addInputs mp pk sk vl tx = do - (spend, change) <- selectCoin (second (view Ledger.ciTxOutValue) <$> Map.toList mp) vl - let - - addTxIns = - let ins = Tx.pubKeyTxIn . fst <$> spend - in over Tx.inputs (sort . (++) ins) - - addTxOut = - if Value.isZero change - then id - else addOutput pk sk change - - pure $ tx & addTxOut & addTxIns - -- | Given a set of @a@s with coin values, and a target value, select a number -- of @a@ such that their total value is greater than or equal to the target. selectCoin :: ( Member (Error WAPI.WalletAPIError) effs + , Eq a ) - => [(a, Value)] - -> Value - -> Eff effs ([(a, Value)], Value) + => [(a, Value)] -- ^ Possible inputs to choose from + -> Value -- ^ The target value + -> Eff effs ([(a, Value)], Value) -- ^ The chosen inputs and the change selectCoin fnds vl = let total = foldMap snd fnds @@ -574,25 +557,35 @@ selectCoin fnds vl = in if not (total `Value.geq` vl) then err else - let - -- Given the funds of a wallet, we take enough just enough such - -- that it's geq the target value, and if the resulting change - -- is not between 0 and the minimum Ada per tx output. - isTotalValueEnough totalVal = - vl `Value.leq` totalVal && valueIsZeroOrHasMinAda (totalVal PlutusTx.- vl) - fundsWithTotal = zip fnds (drop 1 $ scanl (<>) mempty $ fmap snd fnds) - fundsToSpend = takeUntil (isTotalValueEnough . snd) fundsWithTotal - totalSpent = maybe PlutusTx.zero snd $ listToMaybe $ reverse fundsToSpend - change = totalSpent PlutusTx.- vl - -- Make sure that the change is not less than the minimum amount - -- of lovelace per tx output. - in if valueIsZeroOrHasMinAda change - then pure (fst <$> fundsToSpend, change) - else throwError $ WAPI.ChangeHasLessThanNAda change Ledger.minAdaTxOut - --- | Check that a value is a proper TxOut value or is zero (i.e. the absence of a TxOut) -valueIsZeroOrHasMinAda :: Value -> Bool -valueIsZeroOrHasMinAda v = Value.isZero v || Ada.fromValue v >= Ledger.minAdaTxOut + -- Select inputs per asset class, sorting so we do Ada last. + -- We want to do the non-Ada asset classes first, because utxo's often contain + -- extra Ada because of fees or minAda constraints. So when we are done with the + -- non-Ada asset classes we probably already have picked some Ada too. + let (usedFinal, remainderFinal) = foldl' step ([], vl) (sortOn Down $ Value.flattenValue vl) + step (used, remainder) (cur, tok, _) = + let (used', remainder') = selectCoinSingle cur tok (fnds \\ used) remainder + in (used <> used', remainder') + in pure (usedFinal, PlutusTx.negate remainderFinal) + +selectCoinSingle + :: Value.CurrencySymbol + -> Value.TokenName + -> [(a, Value)] -- ^ Possible inputs to choose from + -> Value -- ^ The target value + -> ([(a, Value)], Value) -- ^ The chosen inputs and the remainder +selectCoinSingle cur tok fnds' vl = + let + -- We only want the values that contain the given asset class, + -- and want the single currency values first, + -- so that we're picking inputs that contain *only* the given asset class when possible. + fnds = sortOn (length . Value.symbols . snd) $ filter (\(_, v) -> Value.valueOf v cur tok > 0) fnds' + -- Given the funds of a wallet, we take enough just enough from + -- the target value such that the asset class value of the remainder is <= 0. + fundsWithRemainder = zip fnds (drop 1 $ scanl (PlutusTx.-) vl $ fmap snd fnds) + fundsToSpend = takeUntil (\(_, v) -> Value.valueOf v cur tok <= 0) fundsWithRemainder + remainder = maybe vl snd $ listToMaybe $ reverse fundsToSpend + in (fst <$> fundsToSpend, remainder) + -- | Removes transaction outputs with empty datum and empty value. removeEmptyOutputs :: Tx -> Tx diff --git a/plutus-contract/test/Spec.hs b/plutus-contract/test/Spec.hs index 21fb2acf38..37903550fd 100644 --- a/plutus-contract/test/Spec.hs +++ b/plutus-contract/test/Spec.hs @@ -12,7 +12,9 @@ import Spec.Rows qualified import Spec.Secrets qualified import Spec.State qualified import Spec.ThreadToken qualified -import Spec.TimeValidity qualified +import Spec.TxConstraints.MustSpendAtLeast qualified +import Spec.TxConstraints.RequiredSigner qualified +import Spec.TxConstraints.TimeValidity qualified import Test.Tasty (TestTree, defaultMain, testGroup) main :: IO () @@ -26,7 +28,9 @@ tests = testGroup "plutus-contract" [ Spec.State.tests, Spec.Rows.tests, Spec.ThreadToken.tests, - Spec.TimeValidity.tests, + Spec.TxConstraints.MustSpendAtLeast.tests, + Spec.TxConstraints.RequiredSigner.tests, + Spec.TxConstraints.TimeValidity.tests, Spec.Secrets.tests, Spec.ErrorChecking.tests, Spec.Plutus.Contract.Wallet.tests, diff --git a/plutus-contract/test/Spec/TxConstraints/MustSpendAtLeast.hs b/plutus-contract/test/Spec/TxConstraints/MustSpendAtLeast.hs new file mode 100644 index 0000000000..61f946872e --- /dev/null +++ b/plutus-contract/test/Spec/TxConstraints/MustSpendAtLeast.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Spec.TxConstraints.MustSpendAtLeast(tests) where + +import Control.Monad (void) +import Test.Tasty (TestTree, testGroup) + +import Ledger qualified +import Ledger.Ada qualified as Ada +import Ledger.Constraints.OffChain qualified as Constraints (ownPaymentPubKeyHash, plutusV1TypedValidatorLookups, + unspentOutputs) +import Ledger.Constraints.OnChain.V1 qualified as Constraints (checkScriptContext) +import Ledger.Constraints.TxConstraints qualified as Constraints (collectFromTheScript, mustIncludeDatum, + mustPayToTheScript, mustSpendAtLeast) +import Ledger.Tx qualified as Tx +import Ledger.Typed.Scripts qualified as Scripts +import Plutus.Contract as Con +import Plutus.Contract.Test (assertFailedTransaction, assertValidatedTransactionCount, checkPredicateOptions, + defaultCheckOptions, w1) +import Plutus.Trace qualified as Trace +import Plutus.V1.Ledger.Api (BuiltinByteString, Datum (Datum), ScriptContext, Validator, ValidatorHash) +import Plutus.V1.Ledger.Scripts (ScriptError (EvaluationError)) +import PlutusTx qualified +import PlutusTx.Prelude qualified as P +import Prelude hiding (not) + +tests :: TestTree +tests = + testGroup "MustSpendAtLeast" + [ entireScriptBalance + , lessThanScriptBalance + --, higherThanScriptBalanceWithoutWalletPubkeyLookup -- Failing due to PLT-665 + --, higherThanScriptBalanceWithWalletPubkeyLookup -- Failing due to PLT-665 + , phase2Failure + ] + +scriptBalance :: Integer +scriptBalance = 25_000_000 + +mustSpendAtLeastContract :: Integer -> Integer -> Ledger.PaymentPubKeyHash-> Contract () Empty ContractError () +mustSpendAtLeastContract offAmt onAmt pkh = do + let lookups1 = Constraints.plutusV1TypedValidatorLookups typedValidator + tx1 = Constraints.mustPayToTheScript onAmt (Ada.lovelaceValueOf scriptBalance) + ledgerTx1 <- submitTxConstraintsWith lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + + utxos <- utxosAt scrAddress + let lookups2 = Constraints.plutusV1TypedValidatorLookups typedValidator + <> Constraints.unspentOutputs utxos + <> Constraints.ownPaymentPubKeyHash pkh + tx2 = + Constraints.collectFromTheScript utxos () + <> Constraints.mustIncludeDatum (Datum $ PlutusTx.toBuiltinData onAmt) + <> Constraints.mustSpendAtLeast (Ada.lovelaceValueOf offAmt) + ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2 + +trace :: Contract () Empty ContractError () -> Trace.EmulatorTrace () +trace contract = do + void $ Trace.activateContractWallet w1 contract + void $ Trace.waitNSlots 1 + +emptyPubKey :: Ledger.PaymentPubKeyHash +emptyPubKey = PlutusTx.unsafeFromBuiltinData $ PlutusTx.toBuiltinData ("" :: BuiltinByteString) + +entireScriptBalance :: TestTree +entireScriptBalance = + let contract = mustSpendAtLeastContract scriptBalance scriptBalance emptyPubKey + in checkPredicateOptions + defaultCheckOptions + "Successful use of mustSpendAtLeast at script's exact balance" + (assertValidatedTransactionCount 2) + (void $ trace contract) + +lessThanScriptBalance :: TestTree +lessThanScriptBalance = + let amt = scriptBalance - 1 + contract = mustSpendAtLeastContract amt amt emptyPubKey + in checkPredicateOptions + defaultCheckOptions + "Successful use of mustSpendAtLeast below script's balance" + (assertValidatedTransactionCount 2) + (void $ trace contract ) + +-- TODO: These two tests are failing due to PLT-665 +{- +higherThanScriptBalanceWithWalletPubkeyLookup :: TestTree +higherThanScriptBalanceWithWalletPubkeyLookup = + let amt = scriptBalance + 5_000_000 + contract = mustSpendAtLeastContract amt amt $ mockWalletPaymentPubKeyHash w1 + in checkPredicateOptions + defaultCheckOptions + "Validation pass when mustSpendAtLeast is greater than script's balance and wallet's pubkey is included in the lookup" + (assertValidatedTransactionCount 2) + (void $ trace contract) + +higherThanScriptBalanceWithoutWalletPubkeyLookup :: TestTree +higherThanScriptBalanceWithoutWalletPubkeyLookup = + let amt = scriptBalance + 5_000_000 + contract = mustSpendAtLeastContract amt amt $ mockWalletPaymentPubKeyHash w6 + in checkPredicateOptions + defaultCheckOptions + "Fail validation when mustSpendAtLeast is greater than script's balance and wallet's pubkey is not in the lookup" + (assertContractError contract (Trace.walletInstanceTag w1) (\case { ConstraintResolutionContractError Constraints.OwnPubKeyMissing -> True; _ -> False }) "failed to throw error" + .&&. assertValidatedTransactionCount 1) + (void $ trace contract) +-} + +phase2Failure :: TestTree +phase2Failure = + let offAmt = scriptBalance + onAmt = scriptBalance + 1 + contract = mustSpendAtLeastContract offAmt onAmt emptyPubKey + in checkPredicateOptions + defaultCheckOptions + "Fail phase-2 validation when on-chain mustSpendAtLeast is greater than script's balance" + (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("L5":_) _) -> True; _ -> False })) + (void $ trace contract) + +{-# INLINEABLE mkValidator #-} +mkValidator :: Integer -> () -> ScriptContext -> Bool +mkValidator amt _ ctx = P.traceIfFalse "mustSpendAtLeast not satisfied" (Constraints.checkScriptContext @() @() (Constraints.mustSpendAtLeast P.$ Ada.lovelaceValueOf amt) ctx) + +data UnitTest +instance Scripts.ValidatorTypes UnitTest where + type instance DatumType UnitTest = Integer + type instance RedeemerType UnitTest = () + +typedValidator :: Scripts.TypedValidator UnitTest +typedValidator = Scripts.mkTypedValidator @UnitTest + $$(PlutusTx.compile [||mkValidator||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.mkUntypedValidator + +validatorScript :: Validator +validatorScript = Scripts.validatorScript typedValidator + +valHash :: ValidatorHash +valHash = Scripts.validatorHash typedValidator + +scrAddress :: Ledger.Address +scrAddress = Ledger.scriptHashAddress valHash diff --git a/plutus-contract/test/Spec/TxConstraints/RequiredSigner.hs b/plutus-contract/test/Spec/TxConstraints/RequiredSigner.hs new file mode 100644 index 0000000000..40fd390628 --- /dev/null +++ b/plutus-contract/test/Spec/TxConstraints/RequiredSigner.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Spec.TxConstraints.RequiredSigner(tests) where + +import Control.Monad (void) +import Data.Void (Void) +import Test.Tasty (TestTree, testGroup) + +import Data.List (isInfixOf) +import Data.Maybe (fromJust) +import Data.String (fromString) +import Ledger qualified +import Ledger.Ada qualified as Ada +import Ledger.CardanoWallet as CW +import Ledger.Constraints.OffChain qualified as Constraints (paymentPubKey, plutusV1TypedValidatorLookups, + unspentOutputs) +import Ledger.Constraints.OnChain.V1 qualified as Constraints +import Ledger.Constraints.TxConstraints qualified as Constraints (collectFromTheScript, mustBeSignedBy, + mustIncludeDatum, mustPayToTheScript, + requiredSignatories) +import Ledger.Tx qualified as Tx +import Ledger.Typed.Scripts qualified as Scripts +import Plutus.Contract as Con +import Plutus.Contract.Test (assertFailedTransaction, assertValidatedTransactionCount, checkPredicateOptions, + defaultCheckOptions, mockWalletPaymentPubKey, mockWalletPaymentPubKeyHash, w1, w2) +import Plutus.Trace qualified as Trace +import Plutus.V1.Ledger.Scripts (ScriptError (EvaluationError), unitDatum) +import PlutusTx qualified +import Prelude +import Wallet.Emulator.Wallet (signPrivateKeys, walletToMockWallet) + +tests :: TestTree +tests = + testGroup "required signer" + [ + ownWallet + , otherWallet + , otherWalletNoSigningProcess + , withoutOffChainMustBeSignedBy + , phase2FailureMustBeSignedBy + ] + +mustBeSignedByContract :: Ledger.PaymentPubKey -> Ledger.PaymentPubKeyHash -> Contract () Empty ContractError () +mustBeSignedByContract pk pkh = do + let lookups1 = Constraints.plutusV1TypedValidatorLookups mustBeSignedByTypedValidator + tx1 = Constraints.mustPayToTheScript () (Ada.lovelaceValueOf 25_000_000) + ledgerTx1 <- submitTxConstraintsWith lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + + utxos <- utxosAt (Ledger.scriptHashAddress $ Scripts.validatorHash mustBeSignedByTypedValidator) + let lookups2 = + Constraints.plutusV1TypedValidatorLookups mustBeSignedByTypedValidator + <> Constraints.unspentOutputs utxos + <> Constraints.paymentPubKey pk + tx2 = + Constraints.collectFromTheScript utxos pkh + <> Constraints.mustIncludeDatum unitDatum + <> Constraints.mustBeSignedBy pkh + logInfo @String $ "Required Signatories: " ++ show (Constraints.requiredSignatories tx2) + ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2 + +withoutOffChainMustBeSignedByContract :: Ledger.PaymentPubKey -> Ledger.PaymentPubKeyHash -> Contract () Empty ContractError () +withoutOffChainMustBeSignedByContract pk pkh = do + let lookups1 = Constraints.plutusV1TypedValidatorLookups mustBeSignedByTypedValidator + tx1 = Constraints.mustPayToTheScript () (Ada.lovelaceValueOf 25_000_000) + ledgerTx1 <- submitTxConstraintsWith lookups1 tx1 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1 + + utxos <- utxosAt (Ledger.scriptHashAddress $ Scripts.validatorHash mustBeSignedByTypedValidator) + let lookups2 = + Constraints.plutusV1TypedValidatorLookups mustBeSignedByTypedValidator + <> Constraints.unspentOutputs utxos + <> Constraints.paymentPubKey pk + tx2 = + Constraints.collectFromTheScript utxos pkh + <> Constraints.mustIncludeDatum unitDatum + logInfo @String $ "Required Signatories: " ++ show (Constraints.requiredSignatories tx2) + ledgerTx2 <- submitTxConstraintsWith @UnitTest lookups2 tx2 + awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx2 + +ownWallet :: TestTree +ownWallet = + let pk = mockWalletPaymentPubKey w1 + pkh = mockWalletPaymentPubKeyHash w1 + trace = do + void $ Trace.activateContractWallet w1 $ mustBeSignedByContract pk pkh + void $ Trace.waitNSlots 1 + in checkPredicateOptions defaultCheckOptions "own wallet's signature passes on-chain mustBeSignedBy validation" (assertValidatedTransactionCount 2) (void trace) + +otherWallet :: TestTree -- must use Trace.setSigningProcess for w2 +otherWallet = + let pk = mockWalletPaymentPubKey w2 + pkh = mockWalletPaymentPubKeyHash w2 + trace = do + Trace.setSigningProcess w1 (Just $ signPrivateKeys [paymentPrivateKey $ fromJust $ walletToMockWallet w1, paymentPrivateKey $ fromJust $ walletToMockWallet w2]) + void $ Trace.activateContractWallet w1 $ mustBeSignedByContract pk pkh + void $ Trace.waitNSlots 1 + in checkPredicateOptions defaultCheckOptions "other wallet's signature passes on-chain mustBeSignedBy validation" (assertValidatedTransactionCount 2) (void trace) + +otherWalletNoSigningProcess :: TestTree +otherWalletNoSigningProcess = + let pk = mockWalletPaymentPubKey w2 + pkh = mockWalletPaymentPubKeyHash w2 + trace = do + void $ Trace.activateContractWallet w1 $ mustBeSignedByContract pk pkh + void $ Trace.waitNSlots 1 + in checkPredicateOptions defaultCheckOptions "without Trace.setSigningProcess fails phase-1 validation" + (assertFailedTransaction (\_ err _ -> case err of {Ledger.CardanoLedgerValidationError str -> isInfixOf "MissingRequiredSigners" str; _ -> False })) + (void trace) + +withoutOffChainMustBeSignedBy :: TestTree -- there's no "required signer" in the txbody logs but still passes phase-2 so it must be there. Raised https://github.com/input-output-hk/plutus-apps/issues/645. It'd be good to check log output for expected required signer pubkey in these tests. +withoutOffChainMustBeSignedBy = + let pk = mockWalletPaymentPubKey w1 + pkh = mockWalletPaymentPubKeyHash w1 + trace = do + void $ Trace.activateContractWallet w1 $ withoutOffChainMustBeSignedByContract pk pkh + void $ Trace.waitNSlots 1 + in checkPredicateOptions defaultCheckOptions "without mustBeSignedBy off-chain constraint passes mustBeSignedBy on-chain validation because required signer is still included in txbody" + (assertValidatedTransactionCount 2) + (void trace) + +phase2FailureMustBeSignedBy :: TestTree +phase2FailureMustBeSignedBy = + let pk = mockWalletPaymentPubKey w1 + pkh = Ledger.PaymentPubKeyHash $ fromString "76aaef06f38cc98ed08ceb168ddb55bab2ea5df43a6847a99f086fc9" :: Ledger.PaymentPubKeyHash + trace = do + void $ Trace.activateContractWallet w1 $ withoutOffChainMustBeSignedByContract pk pkh + void $ Trace.waitNSlots 1 + in checkPredicateOptions defaultCheckOptions "with wrong pubkey fails on-chain mustBeSignedBy constraint validation" + (assertFailedTransaction (\_ err _ -> case err of {Ledger.ScriptFailure (EvaluationError ("L4":_) _) -> True; _ -> False })) + (void trace) + +{- + validator using mustBeSignedBy constraint +-} + +data UnitTest +instance Scripts.ValidatorTypes UnitTest where + type instance DatumType UnitTest = () + type instance RedeemerType UnitTest = Ledger.PaymentPubKeyHash + +{-# INLINEABLE mustBeSignedByValidator #-} +mustBeSignedByValidator :: () -> Ledger.PaymentPubKeyHash -> Ledger.ScriptContext -> Bool +mustBeSignedByValidator _ pkh ctx = Constraints.checkScriptContext @Void @Void (Constraints.mustBeSignedBy pkh) ctx + +mustBeSignedByTypedValidator :: Scripts.TypedValidator UnitTest +mustBeSignedByTypedValidator = Scripts.mkTypedValidator @UnitTest + $$(PlutusTx.compile [||mustBeSignedByValidator||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.mkUntypedValidator diff --git a/plutus-contract/test/Spec/TimeValidity.hs b/plutus-contract/test/Spec/TxConstraints/TimeValidity.hs similarity index 98% rename from plutus-contract/test/Spec/TimeValidity.hs rename to plutus-contract/test/Spec/TxConstraints/TimeValidity.hs index d68bf3e545..629e3fbf42 100644 --- a/plutus-contract/test/Spec/TimeValidity.hs +++ b/plutus-contract/test/Spec/TxConstraints/TimeValidity.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Spec.TimeValidity(tests) where +module Spec.TxConstraints.TimeValidity(tests) where import Cardano.Api.Shelley (protocolParamProtocolVersion) import Control.Lens hiding (contains, from, (.>)) diff --git a/plutus-hysterical-screams/README.md b/plutus-hysterical-screams/README.md index b7930ce13c..559ed4b826 100644 --- a/plutus-hysterical-screams/README.md +++ b/plutus-hysterical-screams/README.md @@ -1,7 +1,5 @@ # historical-streams -[![Haskell-CI](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/raduom/hysterical-screams/actions/workflows/haskell-ci.yml) - # A study of algebraic specification. ## Define a simplified model. diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs index 43764f152c..e97209b61a 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OffChain.hs @@ -40,6 +40,7 @@ module Ledger.Constraints.OffChain( , validityTimeRange , emptyUnbalancedTx , adjustUnbalancedTx + , adjustTxOut , MkTxError(..) , mkTx , mkSomeTx @@ -438,16 +439,20 @@ mkTx lookups txc = mkSomeTx [SomeLookupsAndConstraints lookups txc] -- | Each transaction output should contain a minimum amount of Ada (this is a -- restriction on the real Cardano network). adjustUnbalancedTx :: Params -> UnbalancedTx -> Either Tx.ToCardanoError ([Ada.Ada], UnbalancedTx) -adjustUnbalancedTx params = alaf Compose (tx . Tx.outputs . traverse) adjustTxOut - where - adjustTxOut :: TxOut -> Either Tx.ToCardanoError ([Ada.Ada], TxOut) - adjustTxOut txOut = - -- Increasing the ada amount can also increase the size in bytes, so start with a rough estimated amount of ada - let txOutEstimate = txOut { txOutValue = txOutValue txOut <> Ada.toValue minAdaTxOut } - in fromPlutusTxOutUnsafe params txOutEstimate <&> \txOut' -> - let minAdaTxOut' = evaluateMinLovelaceOutput params txOut' - missingLovelace = max 0 (minAdaTxOut' - Ada.fromValue (txOutValue txOut)) - in ([missingLovelace], txOut { txOutValue = txOutValue txOut <> Ada.toValue missingLovelace }) +adjustUnbalancedTx params = alaf Compose (tx . Tx.outputs . traverse) (adjustTxOut params) + +-- | Adjust a single transaction output so it contains at least the minimum amount of Ada +-- and return the adjustment (if any) and the updated TxOut. +adjustTxOut :: Params -> TxOut -> Either Tx.ToCardanoError ([Ada.Ada], TxOut) +adjustTxOut params txOut = + -- Increasing the ada amount can also increase the size in bytes, so start with a rough estimated amount of ada + let txOutEstimate = txOut { txOutValue = txOutValue txOut <> Ada.toValue minAdaTxOut } + in fromPlutusTxOutUnsafe params txOutEstimate <&> \txOut' -> + let minAdaTxOut' = evaluateMinLovelaceOutput params txOut' + missingLovelace = minAdaTxOut' - Ada.fromValue (txOutValue txOut) + in if missingLovelace > 0 + then ([missingLovelace], txOut { txOutValue = txOutValue txOut <> Ada.toValue missingLovelace }) + else ([], txOut) -- | Add the remaining balance of the total value that the tx must spend. -- See note [Balance of value spent] diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs index 2bb72b1823..2044af4156 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/OnChain/V1.hs @@ -67,7 +67,7 @@ checkOwnOutputConstraint ctx@ScriptContext{scriptContextTxInfo} ScriptOutputCons let hsh = V.findDatumHash (Ledger.Datum $ toBuiltinData ocDatum) scriptContextTxInfo checkOutput TxOut{txOutValue, txOutDatumHash=Just svh} = Ada.fromValue txOutValue >= Ada.fromValue ocValue - && Ada.fromValue txOutValue <= Ada.fromValue ocValue + Ledger.minAdaTxOut + && Ada.fromValue txOutValue <= Ada.fromValue ocValue + Ledger.maxMinAdaTxOut && Value.noAdaValue txOutValue == Value.noAdaValue ocValue && hsh == Just svh checkOutput _ = False @@ -107,19 +107,18 @@ checkTxConstraint ctx@ScriptContext{scriptContextTxInfo} = \case MustPayToPubKeyAddress (PaymentPubKeyHash pk) _ mdv vl -> let outs = V.txInfoOutputs scriptContextTxInfo hsh dv = V.findDatumHash dv scriptContextTxInfo - checkOutput (Just dv) TxOut{txOutDatumHash=Just svh} = hsh dv == Just svh - -- return 'True' by default meaning we fail only when the provided datum is not found - checkOutput _ _ = True + checkOutput dv TxOut{txOutDatumHash=Just svh} = hsh dv == Just svh + checkOutput _ _ = False in traceIfFalse "La" -- "MustPayToPubKey" - $ vl `leq` V.valuePaidTo scriptContextTxInfo pk && any (checkOutput mdv) outs + $ vl `leq` V.valuePaidTo scriptContextTxInfo pk && maybe True (\dv -> any (checkOutput dv) outs) mdv MustPayToOtherScript vlh _ dv vl -> let outs = V.txInfoOutputs scriptContextTxInfo hsh = V.findDatumHash dv scriptContextTxInfo addr = Address.scriptHashAddress vlh checkOutput TxOut{txOutAddress, txOutValue, txOutDatumHash=Just svh} = Ada.fromValue txOutValue >= Ada.fromValue vl - && Ada.fromValue txOutValue <= Ada.fromValue vl + Ledger.minAdaTxOut + && Ada.fromValue txOutValue <= Ada.fromValue vl + Ledger.maxMinAdaTxOut && Value.noAdaValue txOutValue == Value.noAdaValue vl && hsh == Just svh && txOutAddress == addr diff --git a/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs b/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs index 1f73bdc669..169b291080 100644 --- a/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs +++ b/plutus-ledger-constraints/src/Ledger/Constraints/TxConstraints.hs @@ -9,11 +9,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} {-# OPTIONS_GHC -fno-specialise #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -{-# LANGUAGE TypeApplications #-} + -- | Constraints for transactions module Ledger.Constraints.TxConstraints where @@ -35,8 +36,8 @@ import Ledger.Address (PaymentPubKeyHash, StakePubKeyHash) import Ledger.Tx (ChainIndexTxOut) import Plutus.Script.Utils.V1.Address qualified as PV1 import Plutus.Script.Utils.V2.Address qualified as PV2 -import Plutus.V1.Ledger.Api (Address, Datum, DatumHash, MintingPolicyHash, POSIXTimeRange, Redeemer (Redeemer), - StakeValidatorHash, TxOutRef, Validator, ValidatorHash) +import Plutus.V1.Ledger.Api (Address, Datum, DatumHash, MintingPolicyHash, POSIXTimeRange, Redeemer, StakeValidatorHash, + TxOutRef, Validator, ValidatorHash) import Plutus.V1.Ledger.Interval qualified as I import Plutus.V1.Ledger.Scripts (unitRedeemer) import Plutus.V1.Ledger.Value (TokenName, Value, isZero) @@ -626,9 +627,10 @@ collectFromPlutusV1ScriptFilter -> Validator -> Redeemer -> UntypedConstraints -collectFromPlutusV1ScriptFilter flt am vls (Redeemer red) = +collectFromPlutusV1ScriptFilter flt am vls red = let mp' = fromMaybe Haskell.mempty $ am ^. at (PV1.mkValidatorAddress vls) - in collectFromTheScriptFilter @PlutusTx.BuiltinData @PlutusTx.BuiltinData flt mp' red + ourUtxo = Map.filterWithKey flt mp' + in foldMap (flip mustSpendScriptOutput red) $ Map.keys ourUtxo -- | Given the pay to script address of the 'Validator', collect from it -- all the outputs that match a predicate, using the 'RedeemerValue'. diff --git a/plutus-ledger/src/Ledger/Index.hs b/plutus-ledger/src/Ledger/Index.hs index d299a82008..f48b144bb9 100644 --- a/plutus-ledger/src/Ledger/Index.hs +++ b/plutus-ledger/src/Ledger/Index.hs @@ -38,6 +38,7 @@ module Ledger.Index( mkPV2TxInfo, pubKeyTxIns, scriptTxIns, + maxMinAdaTxOut, -- * Actual validation validateTransaction, validateTransactionOffChain, @@ -355,7 +356,7 @@ checkPositiveValues t = else throwError $ NegativeValue t {-# INLINABLE minAdaTxOut #-} --- Minimum required Ada for each tx output. +-- An estimate of the minimum required Ada for each tx output. -- -- TODO: Should be removed. minAdaTxOut :: Ada @@ -365,6 +366,21 @@ minAdaTxOut = Ada.lovelaceOf minTxOut minTxOut :: Integer minTxOut = 2_000_000 +{-# INLINABLE maxMinAdaTxOut #-} +{- +maxMinAdaTxOut = maxTxOutSize * coinsPerUTxOWord +coinsPerUTxOWord = 34_482 +maxTxOutSize = utxoEntrySizeWithoutVal + maxValSizeInWords + dataHashSize +utxoEntrySizeWithoutVal = 27 +maxValSizeInWords = 500 +dataHashSize = 10 + +These values are partly protocol parameters-based, but since this is used in on-chain code +we want a constant to reduce code size. +-} +maxMinAdaTxOut :: Ada +maxMinAdaTxOut = Ada.lovelaceOf 18_516_834 + -- Minimum required Lovelace for each tx output. -- minLovelaceTxOut :: Lovelace diff --git a/plutus-use-cases/test/Spec/renderGuess.txt b/plutus-use-cases/test/Spec/renderGuess.txt index f15f2db7c5..917af7b20b 100644 --- a/plutus-use-cases/test/Spec/renderGuess.txt +++ b/plutus-use-cases/test/Spec/renderGuess.txt @@ -551,11 +551,11 @@ Balances Carried Forward: Ada: Lovelace: 100000000 ==== Slot #1, Tx #0 ==== -TxId: eb68ec832f29cefb143f7c0a5ced74f361471fba45215495eb375821778a0ff5 +TxId: 91016130edc8e2019fd7ad61d6254f92141b94feee646f653003d2e8289d6b90 Fee: Ada: Lovelace: 184333 Mint: - Signatures PubKey: 8d9de88fbf445b7f6c3875a14daba94caee2ffcb... - Signature: 5840d6563af5a029d44b4f7accbae287e09fc1e3... + Signature: 5840223dcf18a9169684b47675226892a9a18713... Inputs: ---- Input 0 ---- Destination: PaymentPubKeyHash: a2c20c77887ace1cd986193e4e75babd8993cfd5... (Wallet 872cb83b5ee40eb23bfdab1772660c822a48d491) @@ -578,7 +578,7 @@ Inputs: Outputs: ---- Output 0 ---- - Destination: Script: 7eb9ed951293f9ed93fb58cc353ad29630f88d9117969a3766e2100a + Destination: Script: 71d8bc9cdd447ef3890ff5cbd496908c7332084b2aa443aa598956c1 Value: Ada: Lovelace: 8000000 @@ -629,6 +629,6 @@ Balances Carried Forward: Value: Ada: Lovelace: 100000000 - Script: 7eb9ed951293f9ed93fb58cc353ad29630f88d9117969a3766e2100a + Script: 71d8bc9cdd447ef3890ff5cbd496908c7332084b2aa443aa598956c1 Value: Ada: Lovelace: 8000000 \ No newline at end of file