Skip to content
This repository has been archived by the owner on Dec 2, 2024. It is now read-only.

Commit

Permalink
PLT-774: Collateral output (#740)
Browse files Browse the repository at this point in the history
* Update the contributing guide (#729)

* next-node is the new merge (ends PLT-558) (#745)

* SCP-3855: update node dep (#449)

* Update Cardano node et al. dependencies for the Vasil HF

* The Cardano node version will only work on a network with the Vasil release.

* Solve some compile issues

* wip: recovering instances for types from plutus-ledger-api

* wip

* plutus-ledger compiles

* plutus-ledger-constraints compiles

* Fixed warnings in Ledger.Tx.CardanoAPI for fields introduced by the Babbage era. Also adapted hashing functions for PlutusV1 scripts to work on PlutusV2

* Fixed warnings in Ledger.Tx.CardanoAPITemp and added implementation to undefined value

* plutus-contract compiles

* Added alonzoGenesisDefaults implementation (copied from cardano-node because it was deleted over there) to Ledger.Validation

* plutus-chain-index-core compiles

* Fixed compilation errors in playground-common and plutus-contract

* Fix compile errors in plutus-example

* Fix compile errors in plutus-pab

* Fix compile errors in plutus-playground-server

* WIP on plutus-use-cases

* Split Tx.Orphans into multiple Orphans

* Fix compilation errors on plutus-use-cases

* fix compilation issues

* Update nix

* fix formatting

* Remove wrongly commited files

* Update purescript modules

* Commented test on plutus-ledger temporarely until cardano-node is updated

* Update cardano-wallet with fixes for haddock

* Fix plutus-playground-client purescript imports

* Fix warnings in plutus-example

* Fix plutus-uniswap cabal

* Try to turn-off haddock for cardano-wallet

* [plutus-contract]: fix golden tests and commented test until cardano-node is updated

* Add cardano-cli/.../genesis.alonzo.spec.json to fix plutus-example

* Fix comment link to PR

* Comment out the test properly

* Update scripts/protocol-parameters with fresh plutusV1 cost parameters

Co-authored-by: Konstantinos Lambrou-Latreille <[email protected]>

* [chain-index]: export all servant client functions (#492)

* Fix playground client

* Fix streaming

* Fix purescript

* Create separate directories for v1 and v2 plutus scripts (#486)

* Reorganize the plutus-example library to distinguish clearly between V1
and V2 scripts.

* plutus-example reorganization
create v2 example script

* Modify the ScriptContextChecker module to be more generic

* Propagate the changes to the plutus-example apps and tests

* Update required-redeemer.plutus to also check for an inline datum of 42
and to check for an inline datum of 42 in the reference inputs

* Add PlutusV2 minting and staking scripts (#528)

* [chain-index]: add inline datums support and update cardano-node (#488)

* PLT-484 Upgraded cardano-node version to the official 1.35.0 release. (#551)

* Also upgraded cardano-wallet, plutus et al. versions that work with v1.35.0 of the node.

* Updated golden tests in plutus-use-cases and plutus-contract

* Updated version of components to 1.0.0 with cardano-node (#560)

* Updated the cardano-node bundled with plutus-apps to v1.35.0

* Updated version of all components in their respective cabal files to 1.0.0

* Update cardano-node dependency to 1.35.1

* Updated cardano-wallet, plutus and cardano-ledger to match the node
  version.

* Add script equivalence context test for the V2 context. (#588)

* Remove withIsCardanoEra workaround. (#607)

* BlockInMode now carries a IsCardanoEra constraint

* Increase the delay of awaiting in plutus-pab-executables tests (#565)

Set slot's length to 1s for awaiting tx/out status tests to make them stable

* [PLT-81] plutus-chain-index: support inline scripts when querying TxOut of a TxOutRef (#613)

* Make plutus-ledger-api version explicit in Ledger.Tx

* Make pattern match explicit

* Reorder ScriptChainIndexTxOut fields

To highlight they are the same as PublicKeyChainIndexTxOut.

* Add datum to both branches of ChainIndexTxOut

- Unfortunately we need to rename the fields because they have now
  different types.
- In the PublicKeyChainIndexTxOut case, the output datum is optional and
  we can use plutus-ledger-api OutputDatum type.
- In the ScriptChainIndexTxOut case, the output datum is required,
  nothing changes here but the name.

* Add ReferenceScript to ChainIndexTxOut

* Remove old comment

* Rename _ciTxOutDatumPublicKey and _ciTxOutDatumScript into _ciTxOutPublicKeyDatum and _ciTxOutScriptDatum

* Introduce fromReferenceScript

* Add comments to ChainIndexTxOut

* Add minting context equivalent test plutus script (#631)

* Add missing record field `localTxMonitoringClient` (#617)

* PLT-568: Switch to Babbage era (#614)

* Make Babbage the default era for the emulator

* Clean up

* Accept changes in test output

* Workaround for parseBabbageEraInCardanoModeTx

* Fix minAda calculation

* [next-node]: Bump wallet, plutus, ledger, node (#616)

* Bump cardano-node to 1.35.2 and rest of dependencies based on cardano-wallet

* Use '[TxIn]' instead of 'Set TxIn' in 'data Tx' (#623)

* [plutus-ledger]: Use '[TxIn]' instead of 'Set TxIn' in 'data Tx'.
* Add a property test to check Ord instances of TxIn.
* Sort the inputs in fromOnChainTx
* Sort the inputs in `Emulator.Wallet`
* Fix the review notes and the problem with getInput in StateMachine tests

* PLT-445 Add `mustReferencePubKeyOutput` in constraints library (#640)

* PLT-445 Add mustReferencePubKeyOutput in constraints library

* Added the mustReferencePubKeyOutput constraint in
  plutus-ledger-constraints

* Added a test case for the mustReferencePubKeyOutput

* Refactored Ledger.Tx.CardanoAPI to work with PlutusV2 alongside PlutusV1 scripts in the tx inputs.

* Use existing unitRedeemer

* Move TxIn and TxInType to Ledger.Tx

* Add plutus version to ConsumeScriptAddress constructor

* Add costModelParams for PlutusScriptV2

* Fix error codes.

* Renamed mkTxInfo to mkPV1TxInfo, added test for plutus-tx-constraints without implementation and commented for now the off-chain validation in Ledger.Index

* Implement reference inputs in makeTransactionBody'

* Fixed failing test cases for Ledger.Constraints.mustReferencePubKeyOutput

* Add MustUseOutputAsCollateral

* Fix V2 tests. But issues with V1 tests.

* Disable tests

* WIP

* Remove unused code

* PR feedback

* Remove unused code.

* Clean up

* Added additional info in TODO

* Add Arbitrary instances

* Convert plutus-ledger-constraint tests to PV2

* Fixed test in plutus-ledger-constraints

* Fixed PS generator error in playground

* Fix build

* Fix PS

* Fix PS

* More support of plutus version in constraints libs

* Default to PlutusV1 for now

Co-authored-by: Sjoerd Visscher <[email protected]>
Co-authored-by: Sjoerd Visscher <[email protected]>

* Update cardano-node to 1.35.3-rc1 with deps (#647)

* Upgraded to a cardano-wallet compatible with node 1.35.3-rc1 (#657)

* Reorganized dependencies based on cardano-wallet's cabal.project

* Added the new 'protocolParamUTxOCostPerByte' in 'Ledger.Params' which replaces 'protocolParamUTxOCostPerWord'

* Fixed the `Plutus.Contract.Wallet.mkMintingRedeemers` which triggered an error if the redeemers in the tx contained spending redeemers.

* Simplify MustReferencePubKeyOutput to MustReferenceOutput (#661)

* Replace LedgerPlutusVersion with Language type (#662)

* PLT-494: PlutusV2 TypedValidators (#666)

* Move common code to Plutus.Script.Utils.Typed

* Enable V2 TypedValidators

* Enable and fix reference output tests

* Update cardano-node 1.35.3-rc1 -> 1.35.3 (#669)

* PLT-448: inline scripts in constraint libraries (#678)

* Add inline script support to plutus-tx-constraints.

* Add mustOutputInlineValidator and mustOutputInlineMintingPolicy

* Add documentation

* Check there's no inline script in V1

* Fix wrong minAdaTxOut use

* Update renderGuess.txt

* Naming

* PLT-738: Include plutus language versions with scripts (#681)

* Store Plutus language versions in chain-index

* Introduce Versioned scripts

Remove openapi3 as a dependency of plutus-script-utils

* Add hashing for versioned scripts

* PLT-454: mustUseOutputAsCollateral (#690)

* Finish mustUseOutputAsCollateral implementation

* Add testcase

* Add documentation

* Add missing fields to Ledger.Tx.Internal.Tx (#468)

Add missing fields to Ledger.Tx.Internal.Tx.

  * Add certificates and withdrawals to Tx.

  * Move script witnesses to txScripts.

  * Modify TxIn type, rename to TxInput.

  * Put redeemers together with minting scripts.

  * Translate withdrawals in toCardanoTxBody.

  * Export redeemers for signing with wallet.

* Add tests for mustIncludeDatum tx constraint (#700)

* Add tests for mustIncludeDatum tx constraint (3 failing tests need fix)

* run checks

* Add tests for MustPayToPubKeyAddress tx constraint (#701)

* Add tests for mustSpendScriptOutput and mustSpendScriptOutputWithMatchingDatumAndValue tx constraints (#706)

* Add tests for mustSpendScriptOutput and mustSpendScriptOutputWithMatchingDatumAndValue tx constraints

* Fixed the 'Ledger.Constraints.OffChain.typedValidatorLookups' lookup
function so that it adds the validator inside the 'TypedValidator' in
the 'slOtherScripts' lookup value.

Co-authored-by: Konstantinos Lambrou-Latreille <[email protected]>

* plutus-contract emulator: Change the tx output representation of EmulatorTx to use Cardano.Api.TxOut (#698)

* First draft done for plutus-ledger

* plutus-ledger-constraints use Cardano.Tx

* use C.Tx in plutus-tx-constraints

* plutus-chain-index uses C.TxOut

* Forgot to add file

* Fixing my mess with CardanoAPI

* encoding via plutus.TxOut (can't work, no NetworkId)

* Fix code for the use cases

* Fix a bug in balanceTx

* Fix 0 ada outputs error

* Dirty fix for the uniswap check

* Use Cardano.Tx txId

* fix uniswap test

* Fix double satisfaction

* Fix Marconi

* Add TxOut typeclasses

* Remove unused imports

* Fix failing tests

* Clean import

* Fix pab

* Fix golden values

* Fix golden test

* Fix more plutus packages

* Rmove useless param from ChainIndex.Lib

* Fik playground

* Remove commented code

* Include several fixes following Konstantinos' review

* Add a Pretty TxOut and clean uniswap

* Remove useless stuff in playground

* error in generators display the original cause

* Fix imports

* prettier pretty

* Fix golden tests

* Fix uniswap

* Fix golden tests

* Restore deleted constraints

* Integrate more Sjoerd's comments

* Add tests for mustPayToOtherScript tx constraint (#710)

* Add tests for mustPayToOtherScript tx constraint and 2 more for mustPayToPubKeyAddress

* Fix failing test and reference two PLT tickets

* Refactored MustMint tests to use minting policies and added tests for token burning (#719)

* MustSpendScriptOutput and MustSpendScriptOutputWithMatchingDatumAndValue check the redeemer's presence (#723)

* Add inline datum supports for mustPayToPubKey and mustPayToOtherScript (#721)

* Incremental change for datum

* Work but no inlining

* First working inline datum with V2

* Add tests for inline datum

* add smart constructors for inline datum

* fix PAB

* fixing tx-constraints

* clean up tests

* Address some of Konstantinos' comments

* Separate test group for plutus v2

* Refactor tests in MustPayToPubKeyAddress to ease version handling

* Code clean up

* Code clean up

* Fix unused imports

* Add a way to switch to cardano constraints in MustPayToOtherAddress tests

* more clean up

* PR feedbacks

* Remove dead code

* Add refactoring for MustPayToOtherScript tests

* typo

* clean test suites

* Clean up imports

* Fix some false-positives MustSpendScriptOutput tests using versioned minting policies (#725)

* Fix some false-positives MustSpendScriptOutput tests and refactor to use minting policies

* Use Versioned MintingPolicy and add tests for V2 scripts for MustSpendScriptOutput

* Further refactoring

* Improve onchain check for MustSpendScriptOutput and MustSpendScriptOutputWithMatchingDatumAndValue constraints

* tidy up onchain check

* PLT-448: must spend script output with reference (#716)

* Add ownAddress (singular)

* Support reference scripts in TxIn

* Add mustSpendScriptOutputWithReference

* Test using reference scripts

* Fix merge issues

* Direct conversion from ChainIndexTxOut to the new TxOut

* Push Versioned inside Either

* Accept test outputs

* Fix reference script support in ledger-constraints

* Fix comments

* Add ownAddress (singular)

* Support reference scripts in TxIn

* Add mustSpendScriptOutputWithReference

* Test using reference scripts

* Fix merge issues

* Direct conversion from ChainIndexTxOut to the new TxOut

* Push Versioned inside Either

* Accept test outputs

* Fix reference script support in ledger-constraints

* Fix comments

* PR feedback

* More PR feedback

* Fix merge issues

* PLT-807 Change behavior of MustPayToPubKeyAddress and MustPayToOtherScript w.r.t datum in transaction body (#705)

* Changed `MustPayToPubKeyAddress` and `MustPayToOtherScript` so that
  the user needs to explicitly specify if he wants:
    * the datum to only be included as a hash in the transaction
      output
    * the datum to be included as a hash in the transaction output
      as well as in the transaction body
    * the datum to be inlined in the transaction output

* Changed the name of the constraint `MustIncludeDatum` to
  `MustIncludeDatumInTx` and `MustHashDatum` to
  `MustIncludeDatumInTxWithHash`. These constraint don't modify the
  transaction anymore, but simply check that the datum is part of the
  transaction body.

* Added a note on the 'Plutus.Contract.Oracle' module explaining why it
  doesn't work in it's current form.

* Commented out failing test cases in `plutus-use-cases` that use the
  'Plutus.Contract.Oracle' module.

* PLT-511: collateral output in chain index (#730)

* Add collateral output support to chain index

* Generate invalid transactions in tests too

* PR feedback

* PLT-990 Removed Plutus.Contract.Wallet.finalize as we instead set the validity range of a transaction directly in `plutus-ledger-constraints` (since we now have access to the `SlotConfig`) (#741)

* Update the contributing guide (#729)

Co-authored-by: Evgenii Akentev <[email protected]>
Co-authored-by: Konstantinos Lambrou-Latreille <[email protected]>
Co-authored-by: Jordan Millar <[email protected]>
Co-authored-by: Andrea Bedini <[email protected]>
Co-authored-by: Markus Läll <[email protected]>
Co-authored-by: Sjoerd Visscher <[email protected]>
Co-authored-by: Sjoerd Visscher <[email protected]>
Co-authored-by: Jamie Bertram <[email protected]>
Co-authored-by: Karol Ochman-Milarski <[email protected]>
Co-authored-by: James <[email protected]>
Co-authored-by: Ziyang Liu <[email protected]>

* Revert "next-node is the new merge (ends PLT-558) (#745)" (#746)

This reverts commit dc3f549.

* chore(deps): bump nixbuild/nix-quick-install-action from 17 to 18 (#743)

Bumps [nixbuild/nix-quick-install-action](https://github.com/nixbuild/nix-quick-install-action) from 17 to 18.
- [Release notes](https://github.com/nixbuild/nix-quick-install-action/releases)
- [Changelog](https://github.com/nixbuild/nix-quick-install-action/blob/master/RELEASE)
- [Commits](nixbuild/nix-quick-install-action@v17...v18)

---
updated-dependencies:
- dependency-name: nixbuild/nix-quick-install-action
  dependency-type: direct:production
  update-type: version-update:semver-major
...

Signed-off-by: dependabot[bot] <[email protected]>

Signed-off-by: dependabot[bot] <[email protected]>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>

* Add proper ToJSON instance for unit test results (#744)

* Add collateral output fields

* Add collateral balancing tests

Signed-off-by: dependabot[bot] <[email protected]>
Co-authored-by: Ziyang Liu <[email protected]>
Co-authored-by: Nicolas B <[email protected]>
Co-authored-by: Evgenii Akentev <[email protected]>
Co-authored-by: Konstantinos Lambrou-Latreille <[email protected]>
Co-authored-by: Jordan Millar <[email protected]>
Co-authored-by: Andrea Bedini <[email protected]>
Co-authored-by: Markus Läll <[email protected]>
Co-authored-by: Jamie Bertram <[email protected]>
Co-authored-by: Karol Ochman-Milarski <[email protected]>
Co-authored-by: James <[email protected]>
Co-authored-by: dependabot[bot] <49699333+dependabot[bot]@users.noreply.github.com>
Co-authored-by: Ulf Norell <[email protected]>
  • Loading branch information
13 people authored Oct 13, 2022
1 parent d4255f0 commit 7f2d304
Show file tree
Hide file tree
Showing 28 changed files with 469 additions and 349 deletions.
6 changes: 3 additions & 3 deletions .github/workflows/test.yml
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,7 @@ jobs:
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v3
- uses: nixbuild/nix-quick-install-action@v17
- uses: nixbuild/nix-quick-install-action@v18
- run: nix-instantiate release.nix --arg supportedSystems '[ builtins.currentSystem ]' --restrict-eval -I . --allowed-uris 'https://github.com/NixOS/nixpkgs https://github.com/input-output-hk https://github.com/NixOS/nixpkgs-channels' --option trusted-public-keys "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/" --show-trace
nix-tests:
strategy:
Expand All @@ -18,7 +18,7 @@ jobs:
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v3
- uses: nixbuild/nix-quick-install-action@v17
- uses: nixbuild/nix-quick-install-action@v18
- run: nix-build -A tests.nixpkgsFmt -A tests.cabalFmt -A tests.purs-tidy -A tests.pngOptimization -A tests.shellcheck -A tests.stylishHaskell --arg supportedSystems '[ builtins.currentSystem ]' --restrict-eval -I . --allowed-uris 'https://github.com/NixOS/nixpkgs https://github.com/input-output-hk https://github.com/NixOS/nixpkgs-channels' --option trusted-public-keys "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/"
check-for-updates:
strategy:
Expand All @@ -27,7 +27,7 @@ jobs:
runs-on: ${{ matrix.os }}
steps:
- uses: actions/checkout@v3
- uses: nixbuild/nix-quick-install-action@v17
- uses: nixbuild/nix-quick-install-action@v18
- run: |
nix --extra-experimental-features 'nix-command flakes' --extra-experimental-features flakes flake lock --option trusted-public-keys "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/"
nix-shell --extra-experimental-features 'nix-command flakes' --command "cd plutus-playground-client && (update-client-deps || update-client-deps)" --option trusted-public-keys "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option substituters "https://hydra.iohk.io https://iohk.cachix.org https://cache.nixos.org/" # Double-call to work around bug in spago2nix on first fetch
Expand Down
2 changes: 1 addition & 1 deletion doc/adr/0005-pab-indexing-solution-integration.rst
Original file line number Diff line number Diff line change
Expand Up @@ -44,7 +44,7 @@ contract in `plutus-use-cases`).
-- Step 3
let refs = Map.keys
$ Map.filter ((==) address . txOutAddress)
$ getCardanoTxUnspentOutputsTx ledgerTx
$ getCardanoTxProducedOutputs ledgerTx
case refs of
[] -> throwing _ScriptOutputMissing pk
[outRef] -> do
Expand Down
6 changes: 3 additions & 3 deletions plutus-chain-index-core/src/Plutus/ChainIndex/Tx.hs
Original file line number Diff line number Diff line change
Expand Up @@ -110,11 +110,11 @@ fromOnChainTx = \case
ctx
Invalid ctx ->
onCardanoTx
(\case tx@Tx{txCollateral, txValidRange, txData, txScripts} ->
(\case tx@Tx{txCollateralInputs, txReturnCollateral, txValidRange, txData, txScripts} ->
ChainIndexTx
{ _citxTxId = txId tx
, _citxInputs = map (fillTxInputWitnesses tx) txCollateral
, _citxOutputs = InvalidTx Nothing -- TODO: update when `Tx` supports collateral output
, _citxInputs = map (fillTxInputWitnesses tx) txCollateralInputs
, _citxOutputs = InvalidTx $ fmap (fromCardanoTxOut . getTxOut) txReturnCollateral
, _citxValidRange = txValidRange
, _citxData = txData
, _citxRedeemers = calculateRedeemerPointers tx
Expand Down
4 changes: 2 additions & 2 deletions plutus-chain-index-core/src/Plutus/ChainIndex/TxIdState.hs
Original file line number Diff line number Diff line change
Expand Up @@ -21,7 +21,7 @@ import Data.FingerTree ((|>))
import Data.FingerTree qualified as FT
import Data.Map qualified as Map
import Data.Monoid (Last (..), Sum (..))
import Ledger (OnChainTx, TxId, eitherTx)
import Ledger (OnChainTx, TxId, onChainTxIsValid)
import Plutus.ChainIndex.Tx (ChainIndexTx (..), citxTxId, validityFromChainIndex)
import Plutus.ChainIndex.Types (BlockNumber (..), Depth (..), Point (..), RollbackState (..), Tip (..),
TxConfirmedState (..), TxIdState (..), TxStatus, TxStatusFailure (..), TxValidity (..))
Expand All @@ -31,7 +31,7 @@ import Plutus.ChainIndex.UtxoState (RollbackFailed (..), RollbackResult (..), Ut
-- | The 'TxStatus' of a transaction right after it was added to the chain
initialStatus :: OnChainTx -> TxStatus
initialStatus tx =
TentativelyConfirmed 0 (eitherTx (const TxInvalid) (const TxValid) tx) ()
TentativelyConfirmed 0 (if onChainTxIsValid tx then TxValid else TxInvalid) ()

-- | Increase the depth of a tentatively confirmed transaction
increaseDepth :: TxStatus -> TxStatus
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -58,8 +58,8 @@ import System.Random.SplitMix
import Test.QuickCheck as QC
import Test.QuickCheck.Property
import Test.QuickCheck.Random as QC
import Test.Tasty as Tasty
import Test.Tasty.Runners as Tasty
import Test.Tasty qualified as Tasty
import Test.Tasty.Runners qualified as Tasty
import Text.Read hiding (lift)

newtype JSONShowRead a = JSONShowRead a
Expand Down Expand Up @@ -90,7 +90,24 @@ instance FromJSON SomeException where
str <- parseJSON v
return $ SomeException (ErrorCall str)

deriving via (JSONShowRead Tasty.Result) instance ToJSON Tasty.Result
data TastyResult = Result
{ resultOutcome :: Tasty.Outcome
, resultDescription :: String
, resultShortDescription :: String
, resultTime :: Tasty.Time
}
deriving (Generic, ToJSON)

deriving instance Generic Tasty.FailureReason
deriving instance ToJSON Tasty.FailureReason
deriving instance ToJSON Tasty.Outcome

instance ToJSON Tasty.Result where
toJSON r = toJSON $ Result { resultOutcome = Tasty.resultOutcome r
, resultDescription = Tasty.resultDescription r
, resultShortDescription = Tasty.resultShortDescription r
, resultTime = Tasty.resultTime r
}

data CertificationReport m = CertificationReport {
_certRes_standardPropertyResult :: QC.Result,
Expand Down Expand Up @@ -208,10 +225,10 @@ checkNoLockedFundsLight opts prf =
mkQCArgs :: CertificationOptions -> Args
mkQCArgs CertificationOptions{..} = stdArgs { chatty = certOptOutput , maxSuccess = certOptNumTests }

runUnitTests :: (CoverageRef -> TestTree) -> CertMonad [Tasty.Result]
runUnitTests :: (CoverageRef -> Tasty.TestTree) -> CertMonad [Tasty.Result]
runUnitTests t = liftIORep $ do
ref <- newCoverageRef
res <- launchTestTree mempty (t ref) $ \ status -> do
res <- Tasty.launchTestTree mempty (t ref) $ \ status -> do
rs <- atomically $ mapM waitForDone (IntMap.elems status)
return $ \ _ -> return rs
cov <- readCoverageRef ref
Expand All @@ -220,8 +237,8 @@ runUnitTests t = liftIORep $ do
waitForDone tv = do
s <- readTVar tv
case s of
Done r -> return r
_ -> retry
Tasty.Done r -> return r
_ -> retry

checkDerived :: forall d m c. (c m => ContractModel (d m))
=> Maybe (Instance c m)
Expand Down
12 changes: 7 additions & 5 deletions plutus-contract/src/Wallet/Emulator/Chain.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,8 @@ import Data.Monoid (Ap (Ap))
import Data.Traversable (for)
import GHC.Generics (Generic)
import Ledger (Block, Blockchain, CardanoTx (..), OnChainTx (..), Params (..), Slot (..), TxId, TxIn (txInRef), Value,
eitherTx, getCardanoTxCollateralInputs, getCardanoTxFee, getCardanoTxId, getCardanoTxValidityRange,
txOutValue)
getCardanoTxCollateralInputs, getCardanoTxFee, getCardanoTxId, getCardanoTxTotalCollateral,
getCardanoTxValidityRange, txOutValue, unOnChain)
import Ledger.Index qualified as Index
import Ledger.Interval qualified as Interval
import Ledger.Validation qualified as Validation
Expand Down Expand Up @@ -166,8 +166,10 @@ validateBlock params slot@(Slot s) idx txns =
in ValidatedBlock block events idx'

getCollateral :: Index.UtxoIndex -> CardanoTx -> Value
getCollateral idx tx = fromRight (getCardanoTxFee tx) $
alaf Ap foldMap (fmap txOutValue . (`Index.lookup` idx) . txInRef) (getCardanoTxCollateralInputs tx)
getCollateral idx tx = case getCardanoTxTotalCollateral tx of
Just v -> v
Nothing -> fromRight (getCardanoTxFee tx) $
alaf Ap foldMap (fmap txOutValue . (`Index.lookup` idx) . txInRef) (getCardanoTxCollateralInputs tx)

-- | Check whether the given transaction can be validated in the given slot.
canValidateNow :: Slot -> CardanoTx -> Bool
Expand Down Expand Up @@ -204,7 +206,7 @@ addBlock blk st =
st & chainNewestFirst %~ (blk :)
-- The block update may contain txs that are not in this client's
-- `txPool` which will get ignored
& txPool %~ (\\ map (eitherTx id id) blk)
& txPool %~ (\\ map unOnChain blk)

addTxToPool :: CardanoTx -> TxPool -> TxPool
addTxToPool = (:)
Expand Down
2 changes: 1 addition & 1 deletion plutus-contract/src/Wallet/Emulator/MultiAgent.hs
Original file line number Diff line number Diff line change
Expand Up @@ -308,7 +308,7 @@ emulatorStateInitialDist networkId mp = do
where
-- See [Creating wallets with multiple outputs]
mkOutputs (key, vl) = mkOutput key <$> splitInto10 vl
splitInto10 vl = replicate (fromIntegral count) (Ada.toValue (ada `div` count)) ++ remainder
splitInto10 vl = if count <= 1 then [vl] else 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
Expand Down
114 changes: 55 additions & 59 deletions plutus-contract/src/Wallet/Emulator/Wallet.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ module Wallet.Emulator.Wallet where

import Cardano.Api.Shelley (makeSignedTransaction, protocolParamCollateralPercent)
import Cardano.Wallet.Primitive.Types qualified as Cardano.Wallet
import Control.Lens (makeLenses, makePrisms, over, view, (&), (.~), (^.))
import Control.Lens (makeLenses, makePrisms, over, view, (&), (.~), (?~), (^.))
import Control.Monad (foldM, (<=<))
import Control.Monad.Freer (Eff, Member, Members, interpret, type (~>))
import Control.Monad.Freer.Error (Error, runError, throwError)
Expand All @@ -37,7 +37,7 @@ import Data.Aeson qualified as Aeson
import Data.Bifunctor (bimap, first, second)
import Data.Data (Data)
import Data.Default (Default (def))
import Data.Foldable (Foldable (fold), find, foldl')
import Data.Foldable (Foldable (fold), find, foldl', toList)
import Data.List (sort, sortOn, (\\))
import Data.Map qualified as Map
import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe)
Expand Down Expand Up @@ -424,65 +424,75 @@ handleBalanceTx ::
-> UnbalancedTx
-> Eff effs Tx
handleBalanceTx utxo utx = do
params@Params { pProtocolParams } <- WAPI.getClientParams
Params { pProtocolParams } <- WAPI.getClientParams
let filteredUnbalancedTxTx = removeEmptyOutputs (view U.tx utx)
let txInputs = Tx.txInputs filteredUnbalancedTxTx
ownAddr <- gets ownAddress
inputValues <- traverse lookupValue (Tx.txInputs filteredUnbalancedTxTx)
collateral <- traverse lookupValue (Tx.txCollateral filteredUnbalancedTxTx)
let fees = txFee filteredUnbalancedTxTx
left = txMint filteredUnbalancedTxTx <> fold inputValues
right = fees <> foldMap Tx.txOutValue (filteredUnbalancedTxTx ^. Tx.outputs)
collFees = Ada.toValue $ (Ada.fromValue fees * maybe 100 fromIntegral (protocolParamCollateralPercent pProtocolParams)) `Ada.divide` 100
remainingCollFees = collFees PlutusTx.- fold collateral
balance = left PlutusTx.- right
-- filter out inputs from utxo that are already in unBalancedTx
inputsOutRefs = map Tx.txInputRef 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
logDebug NoOutputsAdded
pure filteredUnbalancedTxTx
else do
logDebug $ AddingPublicKeyOutputFor pos
pure $ filteredUnbalancedTxTx & over Tx.outputs (++ newTxOuts)

tx'' <- if Value.isZero neg
then do
logDebug NoInputsAdded
pure tx'
else do
logDebug $ AddingInputsFor neg
pure $ tx' & over Tx.inputs (sort . (++) (fmap Tx.pubKeyTxInput newTxIns))

if remainingCollFees `Value.leq` PlutusTx.zero
then do
logDebug NoCollateralInputsAdded
pure tx''
else do
logDebug $ AddingCollateralInputsFor remainingCollFees
addCollateral utxo remainingCollFees tx''
((neg, newTxIns), (pos, mNewTxOut)) <- calculateTxChanges ownAddr outRefsWithValue $ Value.split balance

txWithOutputsAdded <- if Value.isZero pos
then do
logDebug NoOutputsAdded
pure filteredUnbalancedTxTx
else do
logDebug $ AddingPublicKeyOutputFor pos
pure $ filteredUnbalancedTxTx & over Tx.outputs (++ toList mNewTxOut)

txWithinputsAdded <- if Value.isZero neg
then do
logDebug NoInputsAdded
pure txWithOutputsAdded
else do
logDebug $ AddingInputsFor neg
pure $ txWithOutputsAdded & over Tx.inputs (sort . (++) (fmap Tx.pubKeyTxInput newTxIns))

collateral <- traverse lookupValue (Tx.txCollateralInputs txWithinputsAdded)

let collAddr = maybe ownAddr Ledger.txOutAddress $ Tx.txReturnCollateral txWithinputsAdded
collateralPercent = maybe 100 fromIntegral (protocolParamCollateralPercent pProtocolParams)
collFees = Ada.toValue $ (Ada.fromValue fees * collateralPercent + 99 {- make sure to round up -}) `Ada.divide` 100
collBalance = fold collateral PlutusTx.- collFees

((negColl, newTxInsColl), (_, mNewTxOutColl)) <- calculateTxChanges collAddr outRefsWithValue $ Value.split collBalance

txWithCollateralInputs <- if Value.isZero negColl
then do
logDebug NoCollateralInputsAdded
pure txWithinputsAdded
else do
logDebug $ AddingCollateralInputsFor negColl
pure $ txWithinputsAdded & over Tx.collateralInputs (sort . (++) (fmap Tx.pubKeyTxInput newTxInsColl))

pure $ txWithCollateralInputs & Tx.totalCollateral ?~ collFees & Tx.returnCollateral .~ mNewTxOutColl

type PubKeyTxIn = TxOutRef

calculateTxChanges
:: ( Member (Error WAPI.WalletAPIError) effs
)
=> Params
-> Address -- ^ The address for the change output
calculateTxChanges ::
( Member (Error WAPI.WalletAPIError) effs
, Member NodeClientEffect effs
, Member (State WalletState) effs
)
=> 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, [PubKeyTxIn]), (Value, [TxOut]))
calculateTxChanges params addr utxos (neg, pos) = do
-> Eff effs ((Value, [PubKeyTxIn]), (Value, Maybe TxOut))
calculateTxChanges addr utxos (neg, pos) = do
-- Calculate the change output with minimal ada
(newNeg, newPos, extraTxOuts) <- if Value.isZero pos
then pure (neg, pos, [])
(newNeg, newPos, mExtraTxOut) <- if Value.isZero pos
then pure (neg, pos, Nothing)
else do
params <- WAPI.getClientParams
txOut <- either
(throwError . WAPI.ToCardanoError)
(pure . TxOut)
Expand All @@ -492,7 +502,7 @@ calculateTxChanges params addr utxos (neg, pos) = do
$ U.adjustTxOut params txOut
let missingValue = Ada.toValue (fold missing)
-- Add the missing ada to both sides to keep the balance.
pure (neg <> missingValue, pos <> missingValue, [extraTxOut])
pure (neg <> missingValue, pos <> missingValue, Just extraTxOut)

-- Calculate the extra inputs needed
(spend, change) <- if Value.isZero newNeg
Expand All @@ -502,30 +512,16 @@ calculateTxChanges params addr utxos (neg, pos) = do
if Value.isZero change
then do
-- No change, so the new inputs and outputs have balanced the transaction
pure ((newNeg, fst <$> spend), (newPos, extraTxOuts))
else if null extraTxOuts
pure ((newNeg, fst <$> spend), (newPos, mExtraTxOut))
else if null mExtraTxOut
-- 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)
then calculateTxChanges 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
)
=> Map.Map TxOutRef ChainIndexTxOut -- ^ The current wallet's unspent transaction outputs.
-> Value
-> Tx
-> Eff effs Tx
addCollateral mp vl tx = do
(spend, _) <- selectCoin (filter (Value.isAdaOnlyValue . snd) (second (view Ledger.ciTxOutValue) <$> Map.toList mp)) vl
let addTxCollateral =
let ins = Tx.pubKeyTxInput . fst <$> spend
in over Tx.collateralInputs (sort . (++) ins)
pure $ tx & addTxCollateral
else calculateTxChanges addr utxos (newNeg <> change, newPos <> change)

-- | 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.
Expand Down
2 changes: 1 addition & 1 deletion plutus-contract/src/Wallet/Graph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -108,7 +108,7 @@ txnFlows keys bc = catMaybes (utxoLinks ++ foldMap extract bc')

extract :: (UtxoLocation, OnChainTx) -> [Maybe FlowLink]
extract (loc, tx) =
let targetRef = mkRef $ eitherTx getCardanoTxId getCardanoTxId tx in
let targetRef = mkRef $ getCardanoTxId $ unOnChain tx in
fmap (flow (Just loc) targetRef . txInRef) (consumableInputs tx)
-- make a flow for a TxOutRef

Expand Down
Loading

0 comments on commit 7f2d304

Please sign in to comment.