From ca3c261042878dc990a2e1862e0652e02321ff1f Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 29 Jul 2022 16:23:36 -0600 Subject: [PATCH 01/27] CTL Plutip integration nix setup --- flake.nix | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/flake.nix b/flake.nix index 7e1e73a..b35d5cd 100644 --- a/flake.nix +++ b/flake.nix @@ -24,7 +24,13 @@ perSystem = nixpkgs.lib.genAttrs defaultSystems; nixpkgsFor = system: import nixpkgs { inherit system; - overlays = [ cardano-transaction-lib.overlay ]; + overlays = [ + cardano-transaction-lib.overlay + (_: _: { + ctl-server = + cardano-transaction-lib.packages.${system}."ctl-server:exe:ctl-server"; + }) + ]; }; psProjectFor = system: let @@ -35,9 +41,14 @@ inherit pkgs src; projectName = "seabug-contracts"; shell = { - packages = [ - pkgs.easy-ps.purs-tidy - pkgs.fd + packages = with pkgs; [ + easy-ps.purs-tidy + fd + plutip-server + ctl-server + ogmios + ogmios-datum-cache + postgresql ]; }; }; From 7c34645c34646b3aa5a7c3956454c888a32d4747 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 29 Jul 2022 16:24:17 -0600 Subject: [PATCH 02/27] Plutip test (with erroring contract) Stake keys aren't provided by plutip so the mintCnft contract fails, but the plutip test environment is working --- exe/Main.purs | 76 ++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 69 insertions(+), 7 deletions(-) diff --git a/exe/Main.purs b/exe/Main.purs index f40887f..0abab8b 100644 --- a/exe/Main.purs +++ b/exe/Main.purs @@ -2,14 +2,76 @@ module Main (main) where import Contract.Prelude -import Contract.Address (ownPaymentPubKeyHash) -import Contract.Config (testnetConfig) -import Contract.Monad (runContract) +import Contract.Address (NetworkId(..), ownPaymentPubKeyHash) +import Contract.Test.Plutip (PlutipConfig, runPlutipContract, withKeyWallet) +import Contract.Transaction (awaitTxConfirmed) +import Data.BigInt (BigInt) +import Data.BigInt as BigInt +import Data.UInt as UInt import Effect.Aff (launchAff_) +import Seabug.Contract.CnftMint (mintCnft) +import Seabug.Contract.MarketPlaceListNft (marketPlaceListNft) +import Seabug.Types (MintCnftParams(..)) +import Serialization.Address (addressBech32) main :: Effect Unit main = launchAff_ $ do - runContract testnetConfig - $ log - <<< show - =<< ownPaymentPubKeyHash + let + distribution :: Array BigInt /\ Array BigInt + distribution = + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] /\ + [ BigInt.fromInt 2_000_000_000 ] + runPlutipContract config distribution \(alice /\ bob) -> do + w <- liftAff $ unwrap alice # _.address $ MainnetId + log $ show $ addressBech32 w + withKeyWallet alice do + txHash /\ cnft <- mintCnft $ + MintCnftParams + { imageUri: + "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" + , tokenNameString: "abcdef" + , name: "Piaggio Ape" + , description: "Seabug Testing" + } + awaitTxConfirmed txHash + log <<< show =<< marketPlaceListNft + "testnetu7qDM8q2XT1S6gEBSicUIqXB6QN60l7B" + pure unit -- sign, balance, submit, etc. + withKeyWallet bob do + log <<< show =<< ownPaymentPubKeyHash + pure unit -- sign, balance, submit, etc. + +config :: PlutipConfig +config = + { host: "127.0.0.1" + , port: UInt.fromInt 8082 + , logLevel: Trace + -- Server configs are used to deploy the corresponding services. + , ogmiosConfig: + { port: UInt.fromInt 1338 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ogmiosDatumCacheConfig: + { port: UInt.fromInt 10000 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ctlServerConfig: + { port: UInt.fromInt 8083 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , postgresConfig: + { host: "127.0.0.1" + , port: UInt.fromInt 5433 + , user: "ctxlib" + , password: "ctxlib" + , dbname: "ctxlib" + } + } From 85f763fd68f49d7f653aebd4cb6d3b36097e2a17 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Mon, 1 Aug 2022 19:12:41 -0600 Subject: [PATCH 03/27] [WIP] Trying to get minting running in plutip --- exe/Main.purs | 33 +++++++++++++++++++++++++++------ 1 file changed, 27 insertions(+), 6 deletions(-) diff --git a/exe/Main.purs b/exe/Main.purs index 0abab8b..0595681 100644 --- a/exe/Main.purs +++ b/exe/Main.purs @@ -2,7 +2,9 @@ module Main (main) where import Contract.Prelude -import Contract.Address (NetworkId(..), ownPaymentPubKeyHash) +import Contract.Address (NetworkId(..), Slot(..), ownPaymentPubKeyHash) +import Contract.Chain (waitNSlots) +import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (PlutipConfig, runPlutipContract, withKeyWallet) import Contract.Transaction (awaitTxConfirmed) import Data.BigInt (BigInt) @@ -11,8 +13,10 @@ import Data.UInt as UInt import Effect.Aff (launchAff_) import Seabug.Contract.CnftMint (mintCnft) import Seabug.Contract.MarketPlaceListNft (marketPlaceListNft) +import Seabug.Contract.Mint (mintWithCollection) import Seabug.Types (MintCnftParams(..)) import Serialization.Address (addressBech32) +import Types.BigNum as BigNum main :: Effect Unit main = launchAff_ $ do @@ -27,6 +31,7 @@ main = launchAff_ $ do w <- liftAff $ unwrap alice # _.address $ MainnetId log $ show $ addressBech32 w withKeyWallet alice do + log "Minting cnft..." txHash /\ cnft <- mintCnft $ MintCnftParams { imageUri: @@ -35,12 +40,28 @@ main = launchAff_ $ do , name: "Piaggio Ape" , description: "Seabug Testing" } + log $ "Waiting for confirmation of cnft transaction: " <> show txHash awaitTxConfirmed txHash - log <<< show =<< marketPlaceListNft - "testnetu7qDM8q2XT1S6gEBSicUIqXB6QN60l7B" - pure unit -- sign, balance, submit, etc. - withKeyWallet bob do - log <<< show =<< ownPaymentPubKeyHash + log $ "Cnft transaction confirmed: " <> show txHash + log $ "Minted cnft: " <> show cnft + log "Minting sgNft..." + log "Waiting some slots..." + void $ waitNSlots (Nat.fromInt' 15) + log "Done waiting, back to minting..." + sgNftTxHash <- mintWithCollection cnft + $ wrap + { authorShare: Nat.fromInt' 1000 + , daoShare: Nat.fromInt' 1000 + , price: Nat.fromInt' $ 100 * 1000000 + , lockLockup: BigInt.fromInt 5 + , lockLockupEnd: Slot $ BigNum.fromInt 5 + , feeVaultKeys: [] + } + log $ "Waiting for confirmation of nft transaction: " <> show sgNftTxHash + awaitTxConfirmed sgNftTxHash + log $ "Nft transaction confirmed: " <> show sgNftTxHash + -- log <<< show =<< marketPlaceListNft + -- "testnetu7qDM8q2XT1S6gEBSicUIqXB6QN60l7B" pure unit -- sign, balance, submit, etc. config :: PlutipConfig From 08f8965596a16fca3347154436b54f142753307c Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Tue, 2 Aug 2022 19:08:12 -0600 Subject: [PATCH 04/27] [WIP][Broken] Testing CTL+plutip stake keys --- exe/Main.purs | 27 ++++++++++++++++----------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/exe/Main.purs b/exe/Main.purs index 0595681..73a778c 100644 --- a/exe/Main.purs +++ b/exe/Main.purs @@ -2,30 +2,35 @@ module Main (main) where import Contract.Prelude -import Contract.Address (NetworkId(..), Slot(..), ownPaymentPubKeyHash) +import Contract.Address (NetworkId(..), Slot(..)) import Contract.Chain (waitNSlots) import Contract.Numeric.Natural as Nat -import Contract.Test.Plutip (PlutipConfig, runPlutipContract, withKeyWallet) +import Contract.Test.Plutip (PlutipConfig, InitialUTxO, runPlutipContract, withKeyWallet, withStakeKey) import Contract.Transaction (awaitTxConfirmed) -import Data.BigInt (BigInt) +import Contract.Wallet (privateKeyFromBytes) import Data.BigInt as BigInt import Data.UInt as UInt -import Effect.Aff (launchAff_) +import Effect.Aff (error, launchAff_) import Seabug.Contract.CnftMint (mintCnft) -import Seabug.Contract.MarketPlaceListNft (marketPlaceListNft) import Seabug.Contract.Mint (mintWithCollection) import Seabug.Types (MintCnftParams(..)) import Serialization.Address (addressBech32) import Types.BigNum as BigNum +import Types.RawBytes (hexToRawBytes) main :: Effect Unit main = launchAff_ $ do + privateStakeKey <- liftM (error "Failed to parse private stake key") + $ privateKeyFromBytes + =<< hexToRawBytes + "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" let - distribution :: Array BigInt /\ Array BigInt distribution = - [ BigInt.fromInt 1_000_000_000 - , BigInt.fromInt 2_000_000_000 - ] /\ + ( withStakeKey (wrap privateStakeKey) + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) /\ [ BigInt.fromInt 2_000_000_000 ] runPlutipContract config distribution \(alice /\ bob) -> do w <- liftAff $ unwrap alice # _.address $ MainnetId @@ -45,8 +50,8 @@ main = launchAff_ $ do log $ "Cnft transaction confirmed: " <> show txHash log $ "Minted cnft: " <> show cnft log "Minting sgNft..." - log "Waiting some slots..." - void $ waitNSlots (Nat.fromInt' 15) + -- log "Waiting some slots..." + -- void $ waitNSlots (Nat.fromInt' 15) log "Done waiting, back to minting..." sgNftTxHash <- mintWithCollection cnft $ wrap From 53c93c616099bfe68686aaaa502c808e31e34165 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 12 Aug 2022 16:44:56 -0600 Subject: [PATCH 05/27] Update CTL version for plutip staking keys --- flake.lock | 16 ++++++++-------- flake.nix | 4 ++-- package.json | 1 + packages.dhall | 3 ++- spago-packages.nix | 18 +++++++++++++++--- 5 files changed, 28 insertions(+), 14 deletions(-) diff --git a/flake.lock b/flake.lock index 6585e18..89c14be 100644 --- a/flake.lock +++ b/flake.lock @@ -566,17 +566,17 @@ "servant-purescript": "servant-purescript_2" }, "locked": { - "lastModified": 1659361157, - "narHash": "sha256-bptnRcen0lm7jnzpO5ycAtwhyhFhNVoC7WS9PTwGDoo=", + "lastModified": 1660312241, + "narHash": "sha256-qBAU3TS8X1IFUvcmJaW66jGgaP2Kwu/5WS7VFwBSPmY=", "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "6c018d43ddfef771bfd586e885ecb0cc7ebd8421", + "rev": "d918af3e09a80e0c3325f0350a97e753d18495bb", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "6c018d43ddfef771bfd586e885ecb0cc7ebd8421", + "rev": "d918af3e09a80e0c3325f0350a97e753d18495bb", "type": "github" } }, @@ -1511,17 +1511,17 @@ "unstable_nixpkgs": "unstable_nixpkgs" }, "locked": { - "lastModified": 1658378474, - "narHash": "sha256-BGZNLo7ABgg6iFY84nYua6jgl8EqhM8bI2bLnLB+z8Q=", + "lastModified": 1659358988, + "narHash": "sha256-YKabPu9FDvUNmSR7+MNwLwiURv4lWQr13r1CuoS3qhM=", "owner": "mlabs-haskell", "repo": "ogmios-datum-cache", - "rev": "1e618a1949667ea3eb972fbaccf34414e8d17e89", + "rev": "47f01a1d9f7dc5cc5246c0c228e5cf5f5ba44399", "type": "github" }, "original": { "owner": "mlabs-haskell", "repo": "ogmios-datum-cache", - "rev": "1e618a1949667ea3eb972fbaccf34414e8d17e89", + "rev": "47f01a1d9f7dc5cc5246c0c228e5cf5f5ba44399", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 5cc145f..92f05fb 100644 --- a/flake.nix +++ b/flake.nix @@ -12,8 +12,8 @@ repo = "cardano-transaction-lib"; # should be same rev as in packages.dhall # To update, do `spago2nix generate` - # `develop` branch - rev = "6c018d43ddfef771bfd586e885ecb0cc7ebd8421"; + # `calum/823-staking-keys-plutip` branch + rev = "d918af3e09a80e0c3325f0350a97e753d18495bb"; }; nixpkgs.follows = "cardano-transaction-lib/nixpkgs"; }; diff --git a/package.json b/package.json index a2b0b61..67723fa 100644 --- a/package.json +++ b/package.json @@ -16,6 +16,7 @@ "dependencies": { "@emurgo/cardano-serialization-lib-browser": "11.0.0", "@emurgo/cardano-serialization-lib-nodejs": "11.0.0", + "base64-js": "^1.5.1", "big-integer": "1.6.51", "blake2b-wasm": "2.4.0", "bufferutil": "4.0.5", diff --git a/packages.dhall b/packages.dhall index 87491fe..6d023d0 100644 --- a/packages.dhall +++ b/packages.dhall @@ -347,6 +347,7 @@ let additions = , "spec" , "spec-quickcheck" , "strings" + , "stringutils" , "tailrec" , "text-encoding" , "these" @@ -362,7 +363,7 @@ let additions = ] , repo = "https://github.com/Plutonomicon/cardano-transaction-lib.git" -- should be same rev as in flake.nix - , version = "6c018d43ddfef771bfd586e885ecb0cc7ebd8421" + , version = "d918af3e09a80e0c3325f0350a97e753d18495bb" } } in upstream // additions diff --git a/spago-packages.nix b/spago-packages.nix index 81cff33..a76f84f 100644 --- a/spago-packages.nix +++ b/spago-packages.nix @@ -211,11 +211,11 @@ let "cardano-transaction-lib" = pkgs.stdenv.mkDerivation { name = "cardano-transaction-lib"; - version = "6c018d43ddfef771bfd586e885ecb0cc7ebd8421"; + version = "d918af3e09a80e0c3325f0350a97e753d18495bb"; src = pkgs.fetchgit { url = "https://github.com/Plutonomicon/cardano-transaction-lib.git"; - rev = "6c018d43ddfef771bfd586e885ecb0cc7ebd8421"; - sha256 = "12hf0qy3vgb4xl15ldb127523p02kjf3psbwisxmklm7qx2ng6vf"; + rev = "d918af3e09a80e0c3325f0350a97e753d18495bb"; + sha256 = "0riya801gm9fb7wyzhlazmla0cgapajja9ppa82m4pxw6kfi8458"; }; phases = "installPhase"; installPhase = "ln -s $src $out"; @@ -1313,6 +1313,18 @@ let installPhase = "ln -s $src $out"; }; + "stringutils" = pkgs.stdenv.mkDerivation { + name = "stringutils"; + version = "v0.0.11"; + src = pkgs.fetchgit { + url = "https://github.com/menelaos/purescript-stringutils.git"; + rev = "e149d04cd5bcc25222c1807f2e1edafb36b5f70e"; + sha256 = "1hbr936bvnm5iil4cfr9qhkbzd1i00yrxf5jd0rnny29df5wsq1w"; + }; + phases = "installPhase"; + installPhase = "ln -s $src $out"; + }; + "tailrec" = pkgs.stdenv.mkDerivation { name = "tailrec"; version = "v5.0.1"; From b499a3c84574ed5c3b099fa59ed362f57e1afef2 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 12 Aug 2022 16:26:31 -0600 Subject: [PATCH 06/27] [Broken] Minting plutip test and minor refactoring This is broken until the slot length issue is addressed: https://github.com/Plutonomicon/cardano-transaction-lib/issues/868 However, hacking a local CTL clone to hardcode the right slot length allows these tests to run properly --- exe/Main.purs | 104 ++--------------- src/Seabug/Contract/CnftMint.purs | 4 +- src/Seabug/Contract/MarketPlaceBuy.purs | 29 +++-- src/Seabug/Contract/MarketPlaceListNft.purs | 12 +- src/Seabug/Contract/Mint.purs | 37 ++++-- src/Seabug/Lock.purs | 8 +- src/Seabug/MarketPlace.purs | 19 ++- test/Main.purs | 28 ++++- test/Minting.purs | 123 ++++++++++++++++++++ test/Util.purs | 104 ++++++++++++----- 10 files changed, 301 insertions(+), 167 deletions(-) create mode 100644 test/Minting.purs diff --git a/exe/Main.purs b/exe/Main.purs index 73a778c..f40887f 100644 --- a/exe/Main.purs +++ b/exe/Main.purs @@ -2,102 +2,14 @@ module Main (main) where import Contract.Prelude -import Contract.Address (NetworkId(..), Slot(..)) -import Contract.Chain (waitNSlots) -import Contract.Numeric.Natural as Nat -import Contract.Test.Plutip (PlutipConfig, InitialUTxO, runPlutipContract, withKeyWallet, withStakeKey) -import Contract.Transaction (awaitTxConfirmed) -import Contract.Wallet (privateKeyFromBytes) -import Data.BigInt as BigInt -import Data.UInt as UInt -import Effect.Aff (error, launchAff_) -import Seabug.Contract.CnftMint (mintCnft) -import Seabug.Contract.Mint (mintWithCollection) -import Seabug.Types (MintCnftParams(..)) -import Serialization.Address (addressBech32) -import Types.BigNum as BigNum -import Types.RawBytes (hexToRawBytes) +import Contract.Address (ownPaymentPubKeyHash) +import Contract.Config (testnetConfig) +import Contract.Monad (runContract) +import Effect.Aff (launchAff_) main :: Effect Unit main = launchAff_ $ do - privateStakeKey <- liftM (error "Failed to parse private stake key") - $ privateKeyFromBytes - =<< hexToRawBytes - "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" - let - distribution = - ( withStakeKey (wrap privateStakeKey) - [ BigInt.fromInt 1_000_000_000 - , BigInt.fromInt 2_000_000_000 - ] - ) /\ - [ BigInt.fromInt 2_000_000_000 ] - runPlutipContract config distribution \(alice /\ bob) -> do - w <- liftAff $ unwrap alice # _.address $ MainnetId - log $ show $ addressBech32 w - withKeyWallet alice do - log "Minting cnft..." - txHash /\ cnft <- mintCnft $ - MintCnftParams - { imageUri: - "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" - , tokenNameString: "abcdef" - , name: "Piaggio Ape" - , description: "Seabug Testing" - } - log $ "Waiting for confirmation of cnft transaction: " <> show txHash - awaitTxConfirmed txHash - log $ "Cnft transaction confirmed: " <> show txHash - log $ "Minted cnft: " <> show cnft - log "Minting sgNft..." - -- log "Waiting some slots..." - -- void $ waitNSlots (Nat.fromInt' 15) - log "Done waiting, back to minting..." - sgNftTxHash <- mintWithCollection cnft - $ wrap - { authorShare: Nat.fromInt' 1000 - , daoShare: Nat.fromInt' 1000 - , price: Nat.fromInt' $ 100 * 1000000 - , lockLockup: BigInt.fromInt 5 - , lockLockupEnd: Slot $ BigNum.fromInt 5 - , feeVaultKeys: [] - } - log $ "Waiting for confirmation of nft transaction: " <> show sgNftTxHash - awaitTxConfirmed sgNftTxHash - log $ "Nft transaction confirmed: " <> show sgNftTxHash - -- log <<< show =<< marketPlaceListNft - -- "testnetu7qDM8q2XT1S6gEBSicUIqXB6QN60l7B" - pure unit -- sign, balance, submit, etc. - -config :: PlutipConfig -config = - { host: "127.0.0.1" - , port: UInt.fromInt 8082 - , logLevel: Trace - -- Server configs are used to deploy the corresponding services. - , ogmiosConfig: - { port: UInt.fromInt 1338 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , ogmiosDatumCacheConfig: - { port: UInt.fromInt 10000 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , ctlServerConfig: - { port: UInt.fromInt 8083 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , postgresConfig: - { host: "127.0.0.1" - , port: UInt.fromInt 5433 - , user: "ctxlib" - , password: "ctxlib" - , dbname: "ctxlib" - } - } + runContract testnetConfig + $ log + <<< show + =<< ownPaymentPubKeyHash diff --git a/src/Seabug/Contract/CnftMint.purs b/src/Seabug/Contract/CnftMint.purs index 868ce99..cce040d 100644 --- a/src/Seabug/Contract/CnftMint.purs +++ b/src/Seabug/Contract/CnftMint.purs @@ -55,12 +55,14 @@ mintCnft (MintCnftParams params) = do =<< hexToByteArray params.tokenNameString let value = singleton curr tn one + + lookups :: Lookups.ScriptLookups Void lookups = mconcat [ Lookups.mintingPolicy policy , Lookups.unspentOutputs $ unwrap utxos ] - constraints :: Constraints.TxConstraints Unit Unit + constraints :: Constraints.TxConstraints Void Void constraints = mconcat [ Constraints.mustMintValue value , Constraints.mustSpendPubKeyOutput oref diff --git a/src/Seabug/Contract/MarketPlaceBuy.purs b/src/Seabug/Contract/MarketPlaceBuy.purs index 071e8e4..4ffcd35 100644 --- a/src/Seabug/Contract/MarketPlaceBuy.purs +++ b/src/Seabug/Contract/MarketPlaceBuy.purs @@ -2,8 +2,8 @@ module Seabug.Contract.MarketPlaceBuy (marketplaceBuy) where import Contract.Prelude -import Contract.Address (getNetworkId, ownPaymentPubKeyHash) -import Contract.Monad (Contract, liftContractE, liftContractM, liftedE, liftedM) +import Contract.Address (ownPaymentPubKeyHash) +import Contract.Monad (Contract, liftContractM, liftedE, liftedM) import Contract.Numeric.Natural (toBigInt) import Contract.PlutusData ( Datum(Datum) @@ -11,15 +11,15 @@ import Contract.PlutusData , toData , unitRedeemer ) -import Contract.ScriptLookups (UnattachedUnbalancedTx, mkUnbalancedTx) import Contract.ScriptLookups - ( mintingPolicy - , validator + ( ScriptLookups + , mintingPolicy , ownPaymentPubKeyHash , typedValidatorLookups , unspentOutputs + , validator ) as ScriptLookups -import Contract.Scripts (typedValidatorEnterpriseAddress) +import Contract.ScriptLookups (UnattachedUnbalancedTx, mkUnbalancedTx) import Contract.Transaction ( TransactionOutput(TransactionOutput) , balanceAndSignTxE @@ -40,7 +40,7 @@ import Data.Bifunctor (lmap) import Data.BigInt (BigInt, fromInt) import Data.Map (insert, toUnfoldable) import Seabug.Contract.Util (minAdaOnlyUTxOValue, setSeabugMetadata) -import Seabug.MarketPlace (marketplaceValidator) +import Seabug.MarketPlace (marketplaceValidator, marketplaceValidatorAddr) import Seabug.Metadata.Share (maxShare) import Seabug.MintingPolicy (mkMintingPolicy, mkTokenName) import Seabug.Types @@ -85,16 +85,12 @@ mkMarketplaceBuyTx (NftData nftData) = do $ liftAff $ Value.scriptCurrencySymbol policy - marketplaceValidator' <- unwrap <$> liftContractE marketplaceValidator - networkId <- getNetworkId + marketplaceValidator' <- unwrap <$> marketplaceValidator let nft = nftData.nftId nft' = unwrap nft newNft = NftId nft' { owner = pkh } - scriptAddr <- - liftContractM "marketplaceBuy: Cannot convert validator hash to address" - $ typedValidatorEnterpriseAddress networkId - $ wrap marketplaceValidator' + scriptAddr <- marketplaceValidatorAddr oldName <- liftedM "marketplaceBuy: Cannot hash old token" $ mkTokenName nft newName <- liftedM "marketplaceBuy: Cannot hash new token" $ mkTokenName newNft @@ -119,8 +115,8 @@ mkMarketplaceBuyTx (NftData nftData) = do filterLowValue :: BigInt - -> (Value.Value -> TxConstraints Unit Unit) - -> TxConstraints Unit Unit + -> (Value.Value -> TxConstraints Void Void) + -> TxConstraints Void Void filterLowValue v t | v < minAdaOnlyUTxOValue = mempty | otherwise = t (Value.lovelaceValueOf v) @@ -144,6 +140,8 @@ mkMarketplaceBuyTx (NftData nftData) = do $ unwrap scriptUtxos let utxosForTx = insert utxo utxoIndex $ unwrap userUtxos + + lookup :: ScriptLookups.ScriptLookups Void lookup = mconcat [ ScriptLookups.mintingPolicy policy , ScriptLookups.typedValidatorLookups $ wrap marketplaceValidator' @@ -152,6 +150,7 @@ mkMarketplaceBuyTx (NftData nftData) = do , ScriptLookups.ownPaymentPubKeyHash pkh ] + constraints :: TxConstraints Void Void constraints = filterLowValue daoShare diff --git a/src/Seabug/Contract/MarketPlaceListNft.purs b/src/Seabug/Contract/MarketPlaceListNft.purs index cae4fe4..2f89ae3 100644 --- a/src/Seabug/Contract/MarketPlaceListNft.purs +++ b/src/Seabug/Contract/MarketPlaceListNft.purs @@ -5,8 +5,7 @@ module Seabug.Contract.MarketPlaceListNft import Contract.Prelude -import Contract.Address (getNetworkId, typedValidatorEnterpriseAddress) -import Contract.Monad (Contract, liftContractE, liftContractM, liftedM) +import Contract.Monad (Contract, liftedM) import Contract.Numeric.Natural as Natural import Contract.PlutusData (fromData, getDatumsByHashes) import Contract.Transaction (TransactionOutput(TransactionOutput)) @@ -19,7 +18,7 @@ import Data.Array (catMaybes, mapMaybe) import Data.Map as Map import Seabug.Contract.Common (NftResult) import Seabug.Contract.Util (minAdaOnlyUTxOValue) -import Seabug.MarketPlace (marketplaceValidator) +import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Metadata (getFullSeabugMetadataWithBackoff) import Seabug.Types (MarketplaceDatum(MarketplaceDatum)) @@ -31,12 +30,7 @@ marketPlaceListNft . String -> Contract r (Array NftResult) marketPlaceListNft projectId = do - marketplaceValidator' <- unwrap <$> liftContractE marketplaceValidator - networkId <- getNetworkId - scriptAddr <- - liftContractM "marketPlaceListNft: Cannot convert validator hash to address" - $ typedValidatorEnterpriseAddress networkId - $ wrap marketplaceValidator' + scriptAddr <- marketplaceValidatorAddr scriptUtxos <- Map.toUnfoldable <<< unwrap <$> liftedM "marketPlaceListNft: Cannot get script Utxos" (utxosAt scriptAddr) diff --git a/src/Seabug/Contract/Mint.purs b/src/Seabug/Contract/Mint.purs index 4581226..9303140 100644 --- a/src/Seabug/Contract/Mint.purs +++ b/src/Seabug/Contract/Mint.purs @@ -1,4 +1,7 @@ -module Seabug.Contract.Mint where +module Seabug.Contract.Mint + ( mintWithCollection + , mintWithCollection' + ) where import Contract.Prelude @@ -9,7 +12,7 @@ import Contract.Address , payPubKeyHashBaseAddress ) import Contract.Chain (currentSlot, currentTime) -import Contract.Monad (Contract, liftContractE, liftContractM, liftedE, liftedM) +import Contract.Monad (Contract, liftContractM, liftedE, liftedM) import Contract.PlutusData (toData) import Contract.ScriptLookups as Lookups import Contract.Scripts (validatorHash) @@ -37,13 +40,14 @@ import Seabug.Types , NftId(..) ) --- | Mint the self-governed NFT for the given collection. -mintWithCollection +-- | Mint the self-governed NFT for the given collection, and return +-- | sgNft info. +mintWithCollection' :: forall (r :: Row Type) . CurrencySymbol /\ TokenName -> MintParams - -> Contract r TransactionHash -mintWithCollection + -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName)) +mintWithCollection' (collectionNftCs /\ collectionNftTn) ( MintParams { price, lockLockup, lockLockupEnd, authorShare, daoShare } @@ -54,9 +58,8 @@ mintWithCollection addr <- liftContractM "Cannot get user address" $ payPubKeyHashBaseAddress networkId owner ownerStake utxos <- liftedM "Cannot get user utxos" $ utxosAt addr - marketplaceValidator' <- unwrap <$> liftContractE marketplaceValidator - lockingScript <- liftedE $ mkLockScript collectionNftCs lockLockup - lockLockupEnd + marketplaceValidator' <- unwrap <$> marketplaceValidator + lockingScript <- mkLockScript collectionNftCs lockLockup lockLockupEnd lockingScriptHash <- liftedM "Could not get locking script hash" $ liftAff $ validatorHash lockingScript let @@ -79,15 +82,17 @@ mintWithCollection now <- currentTime let nftValue = singleton curr tn one + + lookups :: Lookups.ScriptLookups Void lookups = mconcat [ Lookups.mintingPolicy policy, Lookups.unspentOutputs (unwrap utxos) ] - constraints :: Constraints.TxConstraints Unit Unit + constraints :: Constraints.TxConstraints Void Void constraints = mconcat [ Constraints.mustMintValueWithRedeemer (wrap $ toData $ MintToken nft) nftValue , Constraints.mustPayToScript marketplaceValidator'.validatorHash - ( wrap $ toData $ MarketplaceDatum $ + ( wrap $ toData $ MarketplaceDatum { getMarketplaceDatum: curr /\ tn } ) nftValue @@ -109,4 +114,12 @@ mintWithCollection transactionHash <- submit signedTx log $ "Mint transaction successfully submitted with hash: " <> show transactionHash - pure transactionHash + pure $ transactionHash /\ (curr /\ tn) + +-- | Mint the self-governed NFT for the given collection. +mintWithCollection + :: forall (r :: Row Type) + . CurrencySymbol /\ TokenName + -> MintParams + -> Contract r TransactionHash +mintWithCollection c p = fst <$> mintWithCollection' c p diff --git a/src/Seabug/Lock.purs b/src/Seabug/Lock.purs index 316b3cf..aebe6fe 100644 --- a/src/Seabug/Lock.purs +++ b/src/Seabug/Lock.purs @@ -3,13 +3,12 @@ module Seabug.Lock where import Contract.Prelude import Contract.Address (Slot) -import Contract.Monad (Contract, liftContractE) +import Contract.Monad (Contract, liftContractE, liftedE) import Contract.PlutusData (toData) import Contract.Scripts (Validator, applyArgs) import Contract.Value (CurrencySymbol) import Data.Argonaut (Json, JsonDecodeError) import Data.BigInt (BigInt) -import QueryM as QueryM import Seabug.Helpers (jsonReader) mkLockScript @@ -17,10 +16,11 @@ mkLockScript . CurrencySymbol -> BigInt -> Slot - -> Contract r (Either QueryM.ClientError Validator) + -> Contract r Validator mkLockScript collectionNftCs lockup lockupEnd = do script <- liftContractE unappliedLockScript - applyArgs script [ toData collectionNftCs, toData lockup, toData lockupEnd ] + liftedE $ applyArgs script + [ toData collectionNftCs, toData lockup, toData lockupEnd ] unappliedLockScript :: Either JsonDecodeError Validator unappliedLockScript = jsonReader "validator" _unappliedLockScript diff --git a/src/Seabug/MarketPlace.purs b/src/Seabug/MarketPlace.purs index 8214ae3..a155d61 100644 --- a/src/Seabug/MarketPlace.purs +++ b/src/Seabug/MarketPlace.purs @@ -1,8 +1,12 @@ module Seabug.MarketPlace ( marketplaceValidator + , marketplaceValidatorAddr ) where import Contract.Prelude + +import Contract.Address (Address, getNetworkId, typedValidatorEnterpriseAddress) +import Contract.Monad (Contract, liftContractE, liftedM) import Contract.PlutusData (PlutusData) import Contract.Scripts (TypedValidator) import Data.Argonaut (Json, JsonDecodeError) @@ -12,7 +16,18 @@ import Seabug.Helpers (jsonReader) -- Recall, Plutus typed validators map `Any` to `PlutusData` using associated -- type families. We are restricted to functional dependencies in Purescript, -- so are required to type with the output, namely, `PlutusData`. -marketplaceValidator :: Either JsonDecodeError (TypedValidator PlutusData) -marketplaceValidator = jsonReader "typedValidator" _marketplaceValidator +marketplaceValidator' :: Either JsonDecodeError (TypedValidator PlutusData) +marketplaceValidator' = jsonReader "typedValidator" _marketplaceValidator foreign import _marketplaceValidator :: Json + +marketplaceValidator + :: forall (r :: Row Type). Contract r (TypedValidator PlutusData) +marketplaceValidator = liftContractE marketplaceValidator' + +marketplaceValidatorAddr :: forall (r :: Row Type). Contract r Address +marketplaceValidatorAddr = + liftedM "Cannot convert marketplace validator hash to address" + $ typedValidatorEnterpriseAddress + <$> getNetworkId + <*> marketplaceValidator diff --git a/test/Main.purs b/test/Main.purs index f859310..f3c699a 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,12 +3,36 @@ module Test.Main (main) where import Contract.Prelude import Contract.Monad (launchAff_) +import Data.Const (Const) +import Mote (Plan, foldPlan, planT) import Test.Metadata as Metadata -import Test.Util (interpret) +import Test.Minting as Minting +import Test.Spec (Spec, describe, it, pending) +import Test.Spec.Reporter (consoleReporter) +import Test.Spec.Runner (defaultConfig, runSpec') import TestM (TestPlanM) main :: Effect Unit -main = launchAff_ $ interpret unitTestPlan +main = launchAff_ $ interpret do + integrationTestPlan + unitTestPlan unitTestPlan :: TestPlanM Unit unitTestPlan = Metadata.suite + +integrationTestPlan :: TestPlanM Unit +integrationTestPlan = Minting.suite + +interpret :: TestPlanM Unit -> Aff Unit +interpret spif = do + plan <- planT spif + runSpec' defaultConfig { timeout = Just (wrap 30000.0) } [ consoleReporter ] $ + go plan + where + go :: Plan (Const Void) (Aff Unit) -> Spec Unit + go = + foldPlan + (\x -> it x.label $ liftAff x.value) + pending + (\x -> describe x.label $ go x.value) + sequence_ diff --git a/test/Minting.purs b/test/Minting.purs new file mode 100644 index 0000000..f7982c1 --- /dev/null +++ b/test/Minting.purs @@ -0,0 +1,123 @@ +module Test.Minting (suite) where + +import Contract.Prelude + +import Contract.Address + ( Slot(..) + , getNetworkId + , getWalletAddress + , validatorHashEnterpriseAddress + ) +import Contract.Monad (Contract, liftContractM, liftedM) +import Contract.Numeric.Natural as Nat +import Contract.PlutusData (fromData, getDatumByHash) +import Contract.Scripts (Validator, validatorHash) +import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) +import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) +import Contract.Value (CurrencySymbol, TokenName) +import Data.BigInt as BigInt +import Mote (test) +import Seabug.Contract.CnftMint (mintCnft) +import Seabug.Contract.Mint (mintWithCollection') +import Seabug.Lock (mkLockScript) +import Seabug.MarketPlace (marketplaceValidatorAddr) +import Seabug.Types (MarketplaceDatum(..), MintCnftParams(..)) +import Test.Util + ( assertContract + , checkNftAtAddress + , findUtxoWithNft + , plutipConfig + , privateStakeKey + ) +import TestM (TestPlanM) +import Types.BigNum as BigNum + +suite :: TestPlanM Unit +suite = + test "Minting" do + let + distribution = + ( withStakeKey privateStakeKey + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) + runPlutipContract plutipConfig distribution \alice -> + withKeyWallet alice do + cnft <- callMintCnft + aliceAddr <- liftedM "Could not get addr" getWalletAddress + assertContract "Could not find cnft at user address" =<< + checkNftAtAddress cnft aliceAddr + + sgNft /\ lockScript <- callMintSgNft cnft + + scriptAddr <- marketplaceValidatorAddr + TransactionOutput sgNftUtxo <- + liftedM "Could not find sgNft at marketplace address" $ + findUtxoWithNft sgNft scriptAddr + + lockScriptAddr <- liftedM "Could not get locking script addr" + $ validatorHashEnterpriseAddress + <$> getNetworkId + <*> + ( liftedM "Could not get locking script hash" $ liftAff $ + validatorHash lockScript + ) + assertContract "Could not find cnft at locking address" =<< + checkNftAtAddress cnft lockScriptAddr + + -- TODO: Don't test the datums directly, test it via + -- integration with the other contracts + sgNftDatumHash <- liftContractM "sgNft utxo does not have datum hash" + sgNftUtxo.dataHash + rawMpDatum <- liftedM "Could not get sgNft utxo's datum" $ + getDatumByHash sgNftDatumHash + MarketplaceDatum { getMarketplaceDatum: mpDatum } <- + liftContractM "Could not parse sgNft utxo's datum" + $ fromData + $ unwrap rawMpDatum + assertContract "Marketplace datum did not hold sgNft's info" + (mpDatum == sgNft) + +callMintCnft + ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) +callMintCnft = do + log "Minting cnft..." + txHash /\ cnft <- mintCnft $ + MintCnftParams + { imageUri: + "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" + , tokenNameString: "abcdef" + , name: "Piaggio Ape" + , description: "Seabug Testing" + } + log $ "Waiting for confirmation of cnft transaction: " <> show txHash + awaitTxConfirmed txHash + log $ "Cnft transaction confirmed: " <> show txHash + log $ "Minted cnft: " <> show cnft + pure cnft + +callMintSgNft + :: forall (r :: Row Type) + . Tuple CurrencySymbol TokenName + -> Contract r ((CurrencySymbol /\ TokenName) /\ Validator) +callMintSgNft cnft = do + let + lockLockup = BigInt.fromInt 5 + lockLockupEnd = Slot $ BigNum.fromInt 5 + log "Minting sgNft..." + sgNftTxHash /\ sgNft <- mintWithCollection' cnft + $ wrap + { authorShare: Nat.fromInt' 1000 + , daoShare: Nat.fromInt' 1000 + , price: Nat.fromInt' $ 100 * 1000000 + , lockLockup + , lockLockupEnd + , feeVaultKeys: [] + } + log $ "Waiting for confirmation of nft transaction: " <> show + sgNftTxHash + awaitTxConfirmed sgNftTxHash + log $ "Nft transaction confirmed: " <> show sgNftTxHash + lockScript <- mkLockScript (fst cnft) lockLockup lockLockupEnd + pure $ sgNft /\ lockScript diff --git a/test/Util.purs b/test/Util.purs index 3493748..9bb927b 100644 --- a/test/Util.purs +++ b/test/Util.purs @@ -1,31 +1,83 @@ module Test.Util - ( interpret + ( assertContract + , checkNftAtAddress + , findUtxoWithNft + , plutipConfig + , privateStakeKey ) where -import Prelude +import Contract.Prelude -import Data.Const (Const) -import Data.Foldable (sequence_) -import Data.Maybe (Maybe(Just)) -import Data.Newtype (wrap) -import Effect.Aff (Aff) -import Effect.Aff.Class (liftAff) -import Mote (Plan, foldPlan, planT) -import Test.Spec (Spec, describe, it, pending) -import Test.Spec.Reporter (consoleReporter) -import Test.Spec.Runner (defaultConfig, runSpec') -import TestM (TestPlanM) +import Contract.Address (Address) +import Contract.Config (PrivateStakeKey) +import Contract.Monad (Contract, liftedM) +import Contract.Test.Plutip (PlutipConfig) +import Contract.Transaction (TransactionOutput(..)) +import Contract.Utxos (utxosAt) +import Contract.Value (CurrencySymbol, TokenName, valueOf) +import Contract.Wallet (privateKeyFromBytes) +import Data.UInt as UInt +import Effect.Exception (throw) +import Partial.Unsafe (unsafePartial) +import Types.RawBytes (hexToRawBytes) -interpret :: TestPlanM Unit -> Aff Unit -interpret spif = do - plan <- planT spif - runSpec' defaultConfig { timeout = Just (wrap 10000.0) } [ consoleReporter ] $ - go plan - where - go :: Plan (Const Void) (Aff Unit) -> Spec Unit - go = - foldPlan - (\x -> it x.label $ liftAff x.value) - pending - (\x -> describe x.label $ go x.value) - sequence_ +plutipConfig :: PlutipConfig +plutipConfig = + { host: "127.0.0.1" + , port: UInt.fromInt 8082 + , logLevel: Trace + , ogmiosConfig: + { port: UInt.fromInt 1338 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ogmiosDatumCacheConfig: + { port: UInt.fromInt 10000 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ctlServerConfig: + { port: UInt.fromInt 8083 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , postgresConfig: + { host: "127.0.0.1" + , port: UInt.fromInt 5433 + , user: "ctxlib" + , password: "ctxlib" + , dbname: "ctxlib" + } + } + +privateStakeKey :: PrivateStakeKey +privateStakeKey = wrap $ unsafePartial $ fromJust + $ privateKeyFromBytes + =<< hexToRawBytes + "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" + +assertContract :: forall (r :: Row Type). String -> Boolean -> Contract r Unit +assertContract msg cond = if cond then pure unit else liftEffect $ throw msg + +checkNftAtAddress + :: forall (r :: Row Type) + . (CurrencySymbol /\ TokenName) + -> Address + -> Contract r Boolean +checkNftAtAddress nft addr = isJust <$> findUtxoWithNft nft addr + +findUtxoWithNft + :: forall (r :: Row Type) + . (CurrencySymbol /\ TokenName) + -> Address + -> Contract r (Maybe TransactionOutput) +findUtxoWithNft (nftCs /\ nftTn) addr = do + utxos <- liftedM "Could not get utxos" $ map unwrap <$> utxosAt addr + pure $ find + ( \(TransactionOutput { amount }) -> + valueOf amount nftCs nftTn == one + ) + utxos From 7d22ce58fb9dd297682d2fa1f075f49da947105e Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 12 Aug 2022 17:11:21 -0600 Subject: [PATCH 07/27] Add plutip tests to CI --- README.md | 6 +- flake.nix | 7 ++- test/{ => Contract}/Minting.purs | 4 +- test/Contract/Util.purs | 83 +++++++++++++++++++++++++ test/Main.purs | 28 +-------- test/Plutip.purs | 20 +++++++ test/Util.purs | 100 ++++++++----------------------- 7 files changed, 143 insertions(+), 105 deletions(-) rename test/{ => Contract}/Minting.purs (98%) create mode 100644 test/Contract/Util.purs create mode 100644 test/Plutip.purs diff --git a/README.md b/README.md index 859f56c..9b02504 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,11 @@ A library for interacting with Seabug smart contracts via the Cardano Transactio ## Tests -Use `spago test` to run the tests. Something like `nix build .#checks..seabug-contracts` can also be used, where `` is something like `x86_64-linux`. +Use `spago test` to run the tests. Something like `nix build .#checks..seabug-contracts-unit-test` can also be used, where `` is something like `x86_64-linux`. + +### Plutip Tests + +These need a special environment and so are separated into their own suite. Use `spago test --main Test.Plutip` to the plutip tests. Something like `nix build .#checks..seabug-contracts-plutip-test` can also be used. ## Minting diff --git a/flake.nix b/flake.nix index 92f05fb..0f3e089 100644 --- a/flake.nix +++ b/flake.nix @@ -73,9 +73,14 @@ project = psProjectFor system; in { - seabug-contracts = project.runPursTest { + seabug-contracts-unit-test = project.runPursTest { sources = [ "exe" "test" "src" ]; }; + seabug-contracts-plutip-test = project.runPlutipTest { + name = "seabug-contracts-plutip-test"; + testMain = "Test.Plutip"; + env = {}; + }; formatting-check = pkgs.runCommand "formatting-check" { nativeBuildInputs = [ diff --git a/test/Minting.purs b/test/Contract/Minting.purs similarity index 98% rename from test/Minting.purs rename to test/Contract/Minting.purs index f7982c1..0da6429 100644 --- a/test/Minting.purs +++ b/test/Contract/Minting.purs @@ -1,4 +1,4 @@ -module Test.Minting (suite) where +module Test.Contract.Minting (suite) where import Contract.Prelude @@ -22,7 +22,7 @@ import Seabug.Contract.Mint (mintWithCollection') import Seabug.Lock (mkLockScript) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (MarketplaceDatum(..), MintCnftParams(..)) -import Test.Util +import Test.Contract.Util ( assertContract , checkNftAtAddress , findUtxoWithNft diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs new file mode 100644 index 0000000..0f97a83 --- /dev/null +++ b/test/Contract/Util.purs @@ -0,0 +1,83 @@ +module Test.Contract.Util + ( assertContract + , checkNftAtAddress + , findUtxoWithNft + , plutipConfig + , privateStakeKey + ) where + +import Contract.Prelude + +import Contract.Address (Address) +import Contract.Config (PrivateStakeKey) +import Contract.Monad (Contract, liftedM) +import Contract.Test.Plutip (PlutipConfig) +import Contract.Transaction (TransactionOutput(..)) +import Contract.Utxos (utxosAt) +import Contract.Value (CurrencySymbol, TokenName, valueOf) +import Contract.Wallet (privateKeyFromBytes) +import Data.UInt as UInt +import Effect.Exception (throw) +import Partial.Unsafe (unsafePartial) +import Types.RawBytes (hexToRawBytes) + +plutipConfig :: PlutipConfig +plutipConfig = + { host: "127.0.0.1" + , port: UInt.fromInt 8082 + , logLevel: Trace + , ogmiosConfig: + { port: UInt.fromInt 1338 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ogmiosDatumCacheConfig: + { port: UInt.fromInt 10000 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , ctlServerConfig: + { port: UInt.fromInt 8083 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } + , postgresConfig: + { host: "127.0.0.1" + , port: UInt.fromInt 5433 + , user: "ctxlib" + , password: "ctxlib" + , dbname: "ctxlib" + } + } + +privateStakeKey :: PrivateStakeKey +privateStakeKey = wrap $ unsafePartial $ fromJust + $ privateKeyFromBytes + =<< hexToRawBytes + "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" + +assertContract :: forall (r :: Row Type). String -> Boolean -> Contract r Unit +assertContract msg cond = if cond then pure unit else liftEffect $ throw msg + +checkNftAtAddress + :: forall (r :: Row Type) + . (CurrencySymbol /\ TokenName) + -> Address + -> Contract r Boolean +checkNftAtAddress nft addr = isJust <$> findUtxoWithNft nft addr + +findUtxoWithNft + :: forall (r :: Row Type) + . (CurrencySymbol /\ TokenName) + -> Address + -> Contract r (Maybe TransactionOutput) +findUtxoWithNft (nftCs /\ nftTn) addr = do + utxos <- liftedM "Could not get utxos" $ map unwrap <$> utxosAt addr + pure $ find + ( \(TransactionOutput { amount }) -> + valueOf amount nftCs nftTn == one + ) + utxos diff --git a/test/Main.purs b/test/Main.purs index f3c699a..f859310 100644 --- a/test/Main.purs +++ b/test/Main.purs @@ -3,36 +3,12 @@ module Test.Main (main) where import Contract.Prelude import Contract.Monad (launchAff_) -import Data.Const (Const) -import Mote (Plan, foldPlan, planT) import Test.Metadata as Metadata -import Test.Minting as Minting -import Test.Spec (Spec, describe, it, pending) -import Test.Spec.Reporter (consoleReporter) -import Test.Spec.Runner (defaultConfig, runSpec') +import Test.Util (interpret) import TestM (TestPlanM) main :: Effect Unit -main = launchAff_ $ interpret do - integrationTestPlan - unitTestPlan +main = launchAff_ $ interpret unitTestPlan unitTestPlan :: TestPlanM Unit unitTestPlan = Metadata.suite - -integrationTestPlan :: TestPlanM Unit -integrationTestPlan = Minting.suite - -interpret :: TestPlanM Unit -> Aff Unit -interpret spif = do - plan <- planT spif - runSpec' defaultConfig { timeout = Just (wrap 30000.0) } [ consoleReporter ] $ - go plan - where - go :: Plan (Const Void) (Aff Unit) -> Spec Unit - go = - foldPlan - (\x -> it x.label $ liftAff x.value) - pending - (\x -> describe x.label $ go x.value) - sequence_ diff --git a/test/Plutip.purs b/test/Plutip.purs new file mode 100644 index 0000000..8a29f61 --- /dev/null +++ b/test/Plutip.purs @@ -0,0 +1,20 @@ +module Test.Plutip (main) where + +import Contract.Prelude + +import Contract.Monad (launchAff_) +import Test.Contract.Minting as Minting +import Test.Spec.Runner (defaultConfig) +import Test.Util (interpretWithConfig) +import TestM (TestPlanM) + +-- Run with `spago test --main Test.Plutip` +main :: Effect Unit +main = launchAff_ $ interpretWithConfig + -- we don't want to exit because we need to clean up after failure by + -- timeout (something likely to happen with plutip tests) + defaultConfig { timeout = Just $ wrap 30_000.0, exit = false } + plutipTestPlan + +plutipTestPlan :: TestPlanM Unit +plutipTestPlan = Minting.suite diff --git a/test/Util.purs b/test/Util.purs index 9bb927b..5751cf4 100644 --- a/test/Util.purs +++ b/test/Util.purs @@ -1,83 +1,33 @@ module Test.Util - ( assertContract - , checkNftAtAddress - , findUtxoWithNft - , plutipConfig - , privateStakeKey + ( interpret + , interpretWithConfig ) where import Contract.Prelude -import Contract.Address (Address) -import Contract.Config (PrivateStakeKey) -import Contract.Monad (Contract, liftedM) -import Contract.Test.Plutip (PlutipConfig) -import Contract.Transaction (TransactionOutput(..)) -import Contract.Utxos (utxosAt) -import Contract.Value (CurrencySymbol, TokenName, valueOf) -import Contract.Wallet (privateKeyFromBytes) -import Data.UInt as UInt -import Effect.Exception (throw) -import Partial.Unsafe (unsafePartial) -import Types.RawBytes (hexToRawBytes) +import Data.Const (Const) +import Mote (Plan, foldPlan, planT) +import Test.Spec (Spec, describe, it, pending) +import Test.Spec.Reporter (consoleReporter) +import Test.Spec.Runner (defaultConfig, runSpec') +import Test.Spec.Runner as SpecRunner +import TestM (TestPlanM) -plutipConfig :: PlutipConfig -plutipConfig = - { host: "127.0.0.1" - , port: UInt.fromInt 8082 - , logLevel: Trace - , ogmiosConfig: - { port: UInt.fromInt 1338 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , ogmiosDatumCacheConfig: - { port: UInt.fromInt 10000 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , ctlServerConfig: - { port: UInt.fromInt 8083 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } - , postgresConfig: - { host: "127.0.0.1" - , port: UInt.fromInt 5433 - , user: "ctxlib" - , password: "ctxlib" - , dbname: "ctxlib" - } - } +-- | We use `mote` here so that we can use effects to build up a test tree, which +-- | is then interpreted here in a pure context, mainly due to some painful types +-- | in Test.Spec which prohibit effects. +interpret :: TestPlanM Unit -> Aff Unit +interpret = interpretWithConfig defaultConfig { timeout = Just (wrap 10000.0) } -privateStakeKey :: PrivateStakeKey -privateStakeKey = wrap $ unsafePartial $ fromJust - $ privateKeyFromBytes - =<< hexToRawBytes - "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" +interpretWithConfig :: SpecRunner.Config -> TestPlanM Unit -> Aff Unit +interpretWithConfig config spif = do + plan <- planT spif + runSpec' config [ consoleReporter ] $ planToSpec plan -assertContract :: forall (r :: Row Type). String -> Boolean -> Contract r Unit -assertContract msg cond = if cond then pure unit else liftEffect $ throw msg - -checkNftAtAddress - :: forall (r :: Row Type) - . (CurrencySymbol /\ TokenName) - -> Address - -> Contract r Boolean -checkNftAtAddress nft addr = isJust <$> findUtxoWithNft nft addr - -findUtxoWithNft - :: forall (r :: Row Type) - . (CurrencySymbol /\ TokenName) - -> Address - -> Contract r (Maybe TransactionOutput) -findUtxoWithNft (nftCs /\ nftTn) addr = do - utxos <- liftedM "Could not get utxos" $ map unwrap <$> utxosAt addr - pure $ find - ( \(TransactionOutput { amount }) -> - valueOf amount nftCs nftTn == one - ) - utxos +planToSpec :: Plan (Const Void) (Aff Unit) -> Spec Unit +planToSpec = + foldPlan + (\x -> it x.label $ liftAff x.value) + pending + (\x -> describe x.label $ planToSpec x.value) + sequence_ From fe5967ce8c268f9eaf2824256e095de010febed3 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 12 Aug 2022 20:15:46 -0600 Subject: [PATCH 08/27] Add buy plutip test --- src/Seabug/Contract/Mint.purs | 16 ++++---- test/Contract/Buy.purs | 38 +++++++++++++++++++ test/Contract/Minting.purs | 69 +++++------------------------------ test/Contract/Util.purs | 55 +++++++++++++++++++++++++++- test/Plutip.purs | 5 ++- 5 files changed, 111 insertions(+), 72 deletions(-) create mode 100644 test/Contract/Buy.purs diff --git a/src/Seabug/Contract/Mint.purs b/src/Seabug/Contract/Mint.purs index 9303140..46b2e16 100644 --- a/src/Seabug/Contract/Mint.purs +++ b/src/Seabug/Contract/Mint.purs @@ -41,12 +41,12 @@ import Seabug.Types ) -- | Mint the self-governed NFT for the given collection, and return --- | sgNft info. +-- | sgNft's asset class and nft data. mintWithCollection' :: forall (r :: Row Type) . CurrencySymbol /\ TokenName -> MintParams - -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName)) + -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName) /\ NftData) mintWithCollection' (collectionNftCs /\ collectionNftTn) ( MintParams @@ -106,15 +106,13 @@ mintWithCollection' , Constraints.mustValidateIn $ from now ] unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints - unbalancedTxWithMetadata <- setSeabugMetadata - (NftData { nftId: nft, nftCollection: collection }) - curr - unbalancedTx + let nftData = NftData { nftId: nft, nftCollection: collection } + unbalancedTxWithMetadata <- setSeabugMetadata nftData curr unbalancedTx signedTx <- liftedE $ balanceAndSignTxE unbalancedTxWithMetadata transactionHash <- submit signedTx - log $ "Mint transaction successfully submitted with hash: " <> show - transactionHash - pure $ transactionHash /\ (curr /\ tn) + log $ "Mint transaction successfully submitted with hash: " + <> show transactionHash + pure $ transactionHash /\ (curr /\ tn) /\ nftData -- | Mint the self-governed NFT for the given collection. mintWithCollection diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs new file mode 100644 index 0000000..3fd097b --- /dev/null +++ b/test/Contract/Buy.purs @@ -0,0 +1,38 @@ +module Test.Contract.Buy (suite) where + +import Contract.Prelude + +import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) +import Data.BigInt as BigInt +import Mote (only, test) +import Seabug.Contract.MarketPlaceBuy (marketplaceBuy) +import Test.Contract.Util + ( callMintCnft + , callMintSgNft + , mintParams1 + , plutipConfig + , privateStakeKey + ) +import TestM (TestPlanM) + +suite :: TestPlanM Unit +suite = + only $ test "Buy" do + let + distribution = + ( withStakeKey privateStakeKey + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) /\ + ( withStakeKey privateStakeKey + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) + runPlutipContract plutipConfig distribution \(alice /\ bob) -> do + withKeyWallet alice do + cnft <- callMintCnft + _ /\ nftData <- callMintSgNft cnft mintParams1 + withKeyWallet bob do + marketplaceBuy nftData diff --git a/test/Contract/Minting.purs b/test/Contract/Minting.purs index 0da6429..edee340 100644 --- a/test/Contract/Minting.purs +++ b/test/Contract/Minting.purs @@ -3,34 +3,29 @@ module Test.Contract.Minting (suite) where import Contract.Prelude import Contract.Address - ( Slot(..) - , getNetworkId + ( getNetworkId , getWalletAddress , validatorHashEnterpriseAddress ) -import Contract.Monad (Contract, liftContractM, liftedM) -import Contract.Numeric.Natural as Nat +import Contract.Monad (liftContractM, liftedM) import Contract.PlutusData (fromData, getDatumByHash) -import Contract.Scripts (Validator, validatorHash) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) -import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) -import Contract.Value (CurrencySymbol, TokenName) +import Contract.Transaction (TransactionOutput(..)) import Data.BigInt as BigInt import Mote (test) -import Seabug.Contract.CnftMint (mintCnft) -import Seabug.Contract.Mint (mintWithCollection') -import Seabug.Lock (mkLockScript) import Seabug.MarketPlace (marketplaceValidatorAddr) -import Seabug.Types (MarketplaceDatum(..), MintCnftParams(..)) +import Seabug.Types (MarketplaceDatum(..)) import Test.Contract.Util ( assertContract + , callMintCnft + , callMintSgNft , checkNftAtAddress , findUtxoWithNft + , mintParams1 , plutipConfig , privateStakeKey ) import TestM (TestPlanM) -import Types.BigNum as BigNum suite :: TestPlanM Unit suite = @@ -49,7 +44,7 @@ suite = assertContract "Could not find cnft at user address" =<< checkNftAtAddress cnft aliceAddr - sgNft /\ lockScript <- callMintSgNft cnft + sgNft /\ nftData <- callMintSgNft cnft mintParams1 scriptAddr <- marketplaceValidatorAddr TransactionOutput sgNftUtxo <- @@ -59,10 +54,7 @@ suite = lockScriptAddr <- liftedM "Could not get locking script addr" $ validatorHashEnterpriseAddress <$> getNetworkId - <*> - ( liftedM "Could not get locking script hash" $ liftAff $ - validatorHash lockScript - ) + <*> pure (unwrap nftData # _.nftCollection # unwrap # _.lockingScript) assertContract "Could not find cnft at locking address" =<< checkNftAtAddress cnft lockScriptAddr @@ -78,46 +70,3 @@ suite = $ unwrap rawMpDatum assertContract "Marketplace datum did not hold sgNft's info" (mpDatum == sgNft) - -callMintCnft - ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) -callMintCnft = do - log "Minting cnft..." - txHash /\ cnft <- mintCnft $ - MintCnftParams - { imageUri: - "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" - , tokenNameString: "abcdef" - , name: "Piaggio Ape" - , description: "Seabug Testing" - } - log $ "Waiting for confirmation of cnft transaction: " <> show txHash - awaitTxConfirmed txHash - log $ "Cnft transaction confirmed: " <> show txHash - log $ "Minted cnft: " <> show cnft - pure cnft - -callMintSgNft - :: forall (r :: Row Type) - . Tuple CurrencySymbol TokenName - -> Contract r ((CurrencySymbol /\ TokenName) /\ Validator) -callMintSgNft cnft = do - let - lockLockup = BigInt.fromInt 5 - lockLockupEnd = Slot $ BigNum.fromInt 5 - log "Minting sgNft..." - sgNftTxHash /\ sgNft <- mintWithCollection' cnft - $ wrap - { authorShare: Nat.fromInt' 1000 - , daoShare: Nat.fromInt' 1000 - , price: Nat.fromInt' $ 100 * 1000000 - , lockLockup - , lockLockupEnd - , feeVaultKeys: [] - } - log $ "Waiting for confirmation of nft transaction: " <> show - sgNftTxHash - awaitTxConfirmed sgNftTxHash - log $ "Nft transaction confirmed: " <> show sgNftTxHash - lockScript <- mkLockScript (fst cnft) lockLockup lockLockupEnd - pure $ sgNft /\ lockScript diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 0f97a83..4c979f5 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -1,26 +1,77 @@ module Test.Contract.Util ( assertContract + , callMintCnft + , callMintSgNft , checkNftAtAddress , findUtxoWithNft + , mintParams1 , plutipConfig , privateStakeKey ) where import Contract.Prelude -import Contract.Address (Address) +import Contract.Address (Address, Slot(..)) import Contract.Config (PrivateStakeKey) import Contract.Monad (Contract, liftedM) +import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (PlutipConfig) -import Contract.Transaction (TransactionOutput(..)) +import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) import Contract.Utxos (utxosAt) import Contract.Value (CurrencySymbol, TokenName, valueOf) import Contract.Wallet (privateKeyFromBytes) +import Data.BigInt as BigInt import Data.UInt as UInt import Effect.Exception (throw) import Partial.Unsafe (unsafePartial) +import Seabug.Contract.CnftMint (mintCnft) +import Seabug.Contract.Mint (mintWithCollection') +import Seabug.Types (MintCnftParams(..), MintParams, NftData) +import Types.BigNum as BigNum import Types.RawBytes (hexToRawBytes) +mintParams1 :: MintParams +mintParams1 = wrap + { authorShare: Nat.fromInt' 1000 + , daoShare: Nat.fromInt' 1000 + , price: Nat.fromInt' $ 100 * 1000000 + , lockLockup: BigInt.fromInt 5 + , lockLockupEnd: Slot $ BigNum.fromInt 5 + , feeVaultKeys: [] + } + +callMintCnft + ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) +callMintCnft = do + log "Minting cnft..." + txHash /\ cnft <- mintCnft $ + MintCnftParams + { imageUri: + "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" + , tokenNameString: "abcdef" + , name: "Piaggio Ape" + , description: "Seabug Testing" + } + log $ "Waiting for confirmation of cnft transaction: " <> show txHash + awaitTxConfirmed txHash + log $ "Cnft transaction confirmed: " <> show txHash + log $ "Minted cnft: " <> show cnft + pure cnft + +callMintSgNft + :: forall (r :: Row Type) + . Tuple CurrencySymbol TokenName + -> MintParams + -> Contract r ((CurrencySymbol /\ TokenName) /\ NftData) +callMintSgNft cnft mintParams = do + log "Minting sgNft..." + sgNftTxHash /\ sgNft /\ nftData <- mintWithCollection' cnft mintParams + log $ "Waiting for confirmation of nft transaction: " <> show + sgNftTxHash + awaitTxConfirmed sgNftTxHash + log $ "Nft transaction confirmed: " <> show sgNftTxHash + pure $ sgNft /\ nftData + plutipConfig :: PlutipConfig plutipConfig = { host: "127.0.0.1" diff --git a/test/Plutip.purs b/test/Plutip.purs index 8a29f61..392278c 100644 --- a/test/Plutip.purs +++ b/test/Plutip.purs @@ -3,6 +3,7 @@ module Test.Plutip (main) where import Contract.Prelude import Contract.Monad (launchAff_) +import Test.Contract.Buy as Buy import Test.Contract.Minting as Minting import Test.Spec.Runner (defaultConfig) import Test.Util (interpretWithConfig) @@ -17,4 +18,6 @@ main = launchAff_ $ interpretWithConfig plutipTestPlan plutipTestPlan :: TestPlanM Unit -plutipTestPlan = Minting.suite +plutipTestPlan = do + Minting.suite + Buy.suite From 065dcbc11e671189d4d70fb282061dd4530393c3 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Sat, 13 Aug 2022 12:30:58 -0600 Subject: [PATCH 09/27] Updates to buy plutip test --- src/Seabug/Contract/MarketPlaceBuy.purs | 21 ++++- test/Contract/Buy.purs | 56 +++++++++++-- test/Contract/Util.purs | 102 +++++++++++++++++++++++- 3 files changed, 168 insertions(+), 11 deletions(-) diff --git a/src/Seabug/Contract/MarketPlaceBuy.purs b/src/Seabug/Contract/MarketPlaceBuy.purs index 4ffcd35..9e6157d 100644 --- a/src/Seabug/Contract/MarketPlaceBuy.purs +++ b/src/Seabug/Contract/MarketPlaceBuy.purs @@ -1,4 +1,7 @@ -module Seabug.Contract.MarketPlaceBuy (marketplaceBuy) where +module Seabug.Contract.MarketPlaceBuy + ( marketplaceBuy + , marketplaceBuy' + ) where import Contract.Prelude @@ -21,7 +24,8 @@ import Contract.ScriptLookups ) as ScriptLookups import Contract.ScriptLookups (UnattachedUnbalancedTx, mkUnbalancedTx) import Contract.Transaction - ( TransactionOutput(TransactionOutput) + ( TransactionHash + , TransactionOutput(TransactionOutput) , balanceAndSignTxE , submit ) @@ -33,6 +37,7 @@ import Contract.TxConstraints , mustSpendScriptOutput ) import Contract.Utxos (utxosAt) +import Contract.Value (CurrencySymbol, TokenName) import Contract.Value as Value import Contract.Wallet (getWalletAddress) import Data.Array (find) as Array @@ -53,7 +58,16 @@ import Seabug.Types -- | Attempts to submit a transaction where the current user purchases -- | the passed NFT. marketplaceBuy :: forall (r :: Row Type). NftData -> Contract r Unit -marketplaceBuy nftData = do +marketplaceBuy = void <<< marketplaceBuy' + +-- | Attempts to submit a transaction where the current user purchases +-- | the passed NFT, returns the transaction hash and the updated +-- | sgNft. +marketplaceBuy' + :: forall (r :: Row Type) + . NftData + -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName)) +marketplaceBuy' nftData = do unattachedBalancedTx /\ curr /\ newName <- mkMarketplaceBuyTx nftData signedTx <- liftedE ( lmap @@ -67,6 +81,7 @@ marketplaceBuy nftData = do log $ "marketplaceBuy: Transaction successfully submitted with hash: " <> show transactionHash log $ "marketplaceBuy: Buy successful: " <> show (curr /\ newName) + pure $ transactionHash /\ (curr /\ newName) -- https://github.com/mlabs-haskell/plutus-use-cases/blob/927eade6aa9ad37bf2e9acaf8a14ae2fc304b5ba/mlabs/src/Mlabs/EfficientNFT/Contract/MarketplaceBuy.hs -- rev: 2c9ce295ccef4af3f3cb785982dfe554f8781541 diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 3fd097b..7f07395 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -2,16 +2,32 @@ module Test.Contract.Buy (suite) where import Contract.Prelude +import Contract.Address + ( getNetworkId + , getWalletAddress + , ownPaymentPubKeyHash + , payPubKeyHashEnterpriseAddress + ) +import Contract.Monad (liftContractM, liftedM) +import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) +import Contract.Transaction (awaitTxConfirmed) import Data.BigInt as BigInt import Mote (only, test) -import Seabug.Contract.MarketPlaceBuy (marketplaceBuy) +import Seabug.Contract.MarketPlaceBuy (marketplaceBuy') +import Seabug.MarketPlace (marketplaceValidatorAddr) import Test.Contract.Util - ( callMintCnft + ( assertContract + , assertLovelaceDecAtAddr + , assertLovelaceIncAtAddr + , callMintCnft , callMintSgNft + , checkNftAtAddress + , findUtxoWithNft , mintParams1 , plutipConfig , privateStakeKey + , withAssertions ) import TestM (TestPlanM) @@ -30,9 +46,35 @@ suite = , BigInt.fromInt 2_000_000_000 ] ) - runPlutipContract plutipConfig distribution \(alice /\ bob) -> do - withKeyWallet alice do + runPlutipContract plutipConfig distribution \(seller /\ buyer) -> do + networkId <- getNetworkId + sellerPayAddr <- withKeyWallet seller do + sellerPkh <- liftedM "Cannot get seller pkh" ownPaymentPubKeyHash + liftContractM "Could not get seller payment address" $ + payPubKeyHashEnterpriseAddress networkId sellerPkh + oldSgNft /\ nftData <- withKeyWallet seller do cnft <- callMintCnft - _ /\ nftData <- callMintSgNft cnft mintParams1 - withKeyWallet bob do - marketplaceBuy nftData + callMintSgNft cnft mintParams1 + withKeyWallet buyer do + buyerAddr <- liftedM "Could not get buyer addr" getWalletAddress + mpScriptAddr <- marketplaceValidatorAddr + let + minBuyerLoss = Nat.toBigInt (unwrap mintParams1).price + minMpGain = BigInt.fromInt $ 10 * 1000000 + minSellerGain = BigInt.fromInt $ 90 * 1000000 + withAssertions + [ assertLovelaceDecAtAddr "Buyer" buyerAddr minBuyerLoss + , assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain + , assertLovelaceIncAtAddr "Seller" sellerPayAddr minSellerGain + ] + do + txHash /\ newSgNft <- marketplaceBuy' nftData + awaitTxConfirmed txHash + newSgNftUtxo <- + liftedM "Marketplace script did not contain new sgNft" + $ findUtxoWithNft newSgNft mpScriptAddr + assertContract "Marketplace script contained old sgNft" + =<< not + <$> checkNftAtAddress oldSgNft mpScriptAddr + + pure unit diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 4c979f5..86eff6d 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -1,12 +1,19 @@ module Test.Contract.Util ( assertContract + , assertLovelaceChangeAtAddr + , assertLovelaceDecAtAddr + , assertLovelaceIncAtAddr , callMintCnft , callMintSgNft + , checkBalanceChangeAtAddr , checkNftAtAddress , findUtxoWithNft , mintParams1 , plutipConfig , privateStakeKey + , valueAtAddress + , valueToLovelace + , withAssertions ) where import Contract.Prelude @@ -18,9 +25,20 @@ import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (PlutipConfig) import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) import Contract.Utxos (utxosAt) -import Contract.Value (CurrencySymbol, TokenName, valueOf) +import Contract.Value + ( CurrencySymbol + , TokenName + , Value + , getLovelace + , valueOf + , valueToCoin + ) import Contract.Wallet (privateKeyFromBytes) +import Data.BigInt (BigInt) import Data.BigInt as BigInt +import Data.Map as Map +import Data.Monoid.Endo (Endo(..)) +import Data.Newtype (ala) import Data.UInt as UInt import Effect.Exception (throw) import Partial.Unsafe (unsafePartial) @@ -132,3 +150,85 @@ findUtxoWithNft (nftCs /\ nftTn) addr = do valueOf amount nftCs nftTn == one ) utxos + +valueToLovelace :: Value -> BigInt +valueToLovelace = getLovelace <<< valueToCoin + +valueAtAddress :: forall (r :: Row Type). Address -> Contract r (Maybe Value) +valueAtAddress address = utxosAt address <#> map + (fold <<< map _.amount <<< map unwrap <<< Map.values <<< unwrap) + +-- | `checkBalanceChangeAtAddr addrName addr check contract` returns +-- | the result of passing to `check` the total value at the address +-- | `addr` (named `addrName`) before and after calling `contract`. +checkBalanceChangeAtAddr + :: forall (r :: Row Type) a b + . String + -> Address + -> (Value -> Value -> Contract r b) + -> Contract r a + -> Contract r b +checkBalanceChangeAtAddr addrName addr check contract = do + valueBefore <- liftedM ("Could not get " <> addrName <> " value before") $ + valueAtAddress addr + void $ contract + valueAfter <- liftedM ("Could not get " <> addrName <> " value after") $ + valueAtAddress addr + check valueBefore valueAfter + +-- | `assertLovelaceChangeAtAddr addrName addr expected comp contract` +-- | requires the predicate `comp actual expected` to succeed, where +-- | `actual` is the lovelace at `addr` after `contract` minus the +-- | lovelace before. +assertLovelaceChangeAtAddr + :: forall (r :: Row Type) a + . String + -> Address + -> BigInt + -> (BigInt -> BigInt -> Boolean) + -> Contract r a + -> Contract r Unit +assertLovelaceChangeAtAddr addrName addr expected comp contract = + flip (checkBalanceChangeAtAddr addrName addr) contract \valBefore valAfter -> + do + let actual = valueToLovelace valAfter - valueToLovelace valBefore + assertContract + ( "Unexpected lovelace change at addr " <> addrName + <> "\n expected=" + <> show expected + <> "\n actual=" + <> show actual + ) + $ comp actual expected + +-- | Requires that at least the passed amount of lovelace was gained +-- | at the address by calling the contract. +assertLovelaceIncAtAddr + :: forall (r :: Row Type) a + . String + -> Address + -> BigInt + -> Contract r a + -> Contract r Unit +assertLovelaceIncAtAddr addrName addr minGain contract = + assertLovelaceChangeAtAddr addrName addr minGain (>=) contract + +-- | Requires that at least the passed amount of lovelace was lost at +-- | the address by calling the contract. +assertLovelaceDecAtAddr + :: forall (r :: Row Type) a + . String + -> Address + -> BigInt + -> Contract r a + -> Contract r Unit +assertLovelaceDecAtAddr addrName addr minLoss contract = + assertLovelaceChangeAtAddr addrName addr (negate minLoss) (<=) contract + +-- | Composes assertions to be run with a contract. +withAssertions + :: forall (r :: Row Type) a + . Array (Contract r Unit -> Contract r Unit) + -> Contract r a + -> Contract r Unit +withAssertions assertions contract = ala Endo foldMap assertions (void contract) From f62d33e20ea57afd0e6cc9d70d483a32ef897d29 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Tue, 16 Aug 2022 16:38:25 -0600 Subject: [PATCH 10/27] More tests for buy contract --- test/Contract/Buy.purs | 236 +++++++++++++++++++++++++++++-------- test/Contract/Minting.purs | 4 +- test/Contract/Util.purs | 63 +++++++--- 3 files changed, 236 insertions(+), 67 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 74b3303..a14080f 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -3,79 +3,217 @@ module Test.Contract.Buy (suite) where import Contract.Prelude import Contract.Address - ( getNetworkId + ( Address + , getNetworkId , getWalletAddress , ownPaymentPubKeyHash , payPubKeyHashEnterpriseAddress ) -import Contract.Monad (liftContractM, liftedM) +import Contract.Monad (Contract, liftContractM, liftedM) import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) import Contract.Transaction (awaitTxConfirmed) +import Data.BigInt (BigInt) import Data.BigInt as BigInt -import Mote (only, test) +import Mote (group, only, skip, test) import Seabug.Contract.Buy (marketplaceBuy') -import Seabug.Contract.Util (ReturnBehaviour(..)) +import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData) import Seabug.MarketPlace (marketplaceValidatorAddr) +import Seabug.Types (MintParams) import Test.Contract.Util - ( assertContract + ( ContractWrapAssertion + , assertContract , assertLovelaceDecAtAddr , assertLovelaceIncAtAddr , callMintCnft , callMintSgNft , checkNftAtAddress - , findUtxoWithNft , mintParams1 + , mintParams2 + , mintParams3 + , mintParams4 , plutipConfig - , privateStakeKey + , privateStakeKey1 + , privateStakeKey2 , withAssertions ) import TestM (TestPlanM) +type BuyTestData = + { sellerPayAddr :: Address -- The enterprise address of the seller + , buyerAddr :: Address -- The address used by the buyer + , authorPayAddr :: Address -- The enterprise address of the author + , mpScriptAddr :: Address -- The address of the marketplace script + , mintParams :: MintParams -- The params used to mint the bought nft + } + +type PostBuyTestData = + { buyTestData :: BuyTestData + , txData :: SeabugTxData -- The data of the buy transaction + } + +type ExpectedShares = + { minMpGain :: BigInt + , minSellerGain :: BigInt + , minAuthorGain :: BigInt + } + +type BuyTestConfig = + { mintParams :: MintParams + , expectedShares :: ExpectedShares + , retBehaviour :: ReturnBehaviour + , postBuyAssertions :: PostBuyTestData -> Array (Contract () Unit) + } + +buyTestConfig1 :: BuyTestConfig +buyTestConfig1 = + { mintParams: mintParams1 + , expectedShares: + { minMpGain: BigInt.fromInt $ 10 * 1000000 + , minSellerGain: BigInt.fromInt $ 90 * 1000000 + , minAuthorGain: BigInt.fromInt $ 90 * 1000000 + } + , retBehaviour: ToMarketPlace + , postBuyAssertions: nftToMarketPlaceAssert + } + +buyTestConfig2 :: BuyTestConfig +buyTestConfig2 = + { mintParams: mintParams2 + , expectedShares: + { minMpGain: BigInt.fromInt 0 + , minSellerGain: BigInt.fromInt $ 100 * 1000000 + , minAuthorGain: BigInt.fromInt $ 100 * 1000000 + } + , retBehaviour: ToMarketPlace + , postBuyAssertions: nftToMarketPlaceAssert + } + +buyTestConfig3 :: BuyTestConfig +buyTestConfig3 = + { mintParams: mintParams3 + , expectedShares: + { minMpGain: BigInt.fromInt $ 10 * 1000000 + , minSellerGain: BigInt.fromInt $ 90 * 1000000 + , minAuthorGain: BigInt.fromInt $ 90 * 1000000 + } + , retBehaviour: ToMarketPlace + , postBuyAssertions: nftToMarketPlaceAssert + } + +buyTestConfig4 :: BuyTestConfig +buyTestConfig4 = buyTestConfig2 { mintParams = mintParams4 } + suite :: TestPlanM Unit suite = - only $ test "Buy" do - let - distribution = - ( withStakeKey privateStakeKey + only $ group "Buy" do + test "Seller is author, no low prices, nft to marketplace" $ + mkBuyTest buyTestConfig1 + skip $ test "Seller is author, no low prices, nft to buyer" $ + mkBuyTest buyTestConfig1 + { retBehaviour = ToCaller + , postBuyAssertions = nftToBuyerAssert + } + test "Seller is author, low marketplace share, nft to marketplace" $ + mkBuyTest buyTestConfig2 + skip $ test "Seller is author, low marketplace share, nft to buyer" $ + mkBuyTest buyTestConfig2 + { retBehaviour = ToCaller + , postBuyAssertions = nftToBuyerAssert + } + test "Seller is author, low author share, nft to marketplace" $ + mkBuyTest buyTestConfig3 + test + "Seller is author, low author and marketplace shares, nft to marketplace" + $ + mkBuyTest buyTestConfig4 + +nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) +nftToMarketPlaceAssert o@{ buyTestData: { mpScriptAddr } } = + [ assertAddrHasNewAsset mpScriptAddr o + , assertAddrLacksOldAsset mpScriptAddr o + ] + +nftToBuyerAssert :: PostBuyTestData -> Array (Contract () Unit) +nftToBuyerAssert o@{ buyTestData: { buyerAddr, mpScriptAddr } } = + [ assertAddrHasNewAsset buyerAddr o, assertAddrLacksOldAsset mpScriptAddr o ] + +mkBuyTest :: BuyTestConfig -> Aff Unit +mkBuyTest { mintParams, expectedShares, retBehaviour, postBuyAssertions } = + runBuyTest mintParams retBehaviour (mkShareAssertions expectedShares) + postBuyAssertions + +assertAddrHasNewAsset :: Address -> PostBuyTestData -> Contract () Unit +assertAddrHasNewAsset addr { txData } = + assertContract "Address did not contain new sgNft" + =<< checkNftAtAddress txData.newAsset addr + +assertAddrLacksOldAsset :: Address -> PostBuyTestData -> Contract () Unit +assertAddrLacksOldAsset addr { txData } = + assertContract "Address contained old sgNft" + =<< not + <$> checkNftAtAddress txData.oldAsset addr + +mkShareAssertions + :: forall (r :: Row Type) + . ExpectedShares + -> BuyTestData + -> Array (ContractWrapAssertion r) +mkShareAssertions + { minMpGain, minSellerGain, minAuthorGain } + { sellerPayAddr, buyerAddr, authorPayAddr, mpScriptAddr, mintParams } = + let + minBuyerLoss = Nat.toBigInt (unwrap mintParams).price + in + [ assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain + , assertLovelaceIncAtAddr "Seller" sellerPayAddr minSellerGain + , assertLovelaceIncAtAddr "Author" authorPayAddr minAuthorGain + , assertLovelaceDecAtAddr "Buyer" buyerAddr minBuyerLoss + ] + +runBuyTest + :: forall (r :: Row Type) + . MintParams + -> ReturnBehaviour + -> (BuyTestData -> Array (ContractWrapAssertion ())) + -> (PostBuyTestData -> Array (Contract () Unit)) + -> Aff Unit +runBuyTest mintParams retBehaviour getAssertions getAfterAssertions = do + let + distribution = + ( withStakeKey privateStakeKey1 + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) /\ + ( withStakeKey privateStakeKey2 [ BigInt.fromInt 1_000_000_000 , BigInt.fromInt 2_000_000_000 ] - ) /\ - ( withStakeKey privateStakeKey - [ BigInt.fromInt 1_000_000_000 - , BigInt.fromInt 2_000_000_000 - ] - ) - runPlutipContract plutipConfig distribution \(seller /\ buyer) -> do - networkId <- getNetworkId - sellerPayAddr <- withKeyWallet seller do - sellerPkh <- liftedM "Cannot get seller pkh" ownPaymentPubKeyHash - liftContractM "Could not get seller payment address" $ - payPubKeyHashEnterpriseAddress networkId sellerPkh - oldSgNft /\ nftData <- withKeyWallet seller do - cnft <- callMintCnft - callMintSgNft cnft mintParams1 - withKeyWallet buyer do - buyerAddr <- liftedM "Could not get buyer addr" getWalletAddress - mpScriptAddr <- marketplaceValidatorAddr - let - minBuyerLoss = Nat.toBigInt (unwrap mintParams1).price - minMpGain = BigInt.fromInt $ 10 * 1000000 - minSellerGain = BigInt.fromInt $ 90 * 1000000 - withAssertions - [ assertLovelaceDecAtAddr "Buyer" buyerAddr minBuyerLoss - , assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain - , assertLovelaceIncAtAddr "Seller" sellerPayAddr minSellerGain - ] - do - txHash /\ txData <- marketplaceBuy' ToMarketPlace nftData - awaitTxConfirmed txHash - newSgNftUtxo <- - liftedM "Marketplace script did not contain new sgNft" - $ findUtxoWithNft txData.newAsset mpScriptAddr - assertContract "Marketplace script contained old sgNft" - =<< not - <$> checkNftAtAddress oldSgNft mpScriptAddr - - pure unit + ) + runPlutipContract plutipConfig distribution \(seller /\ buyer) -> do + networkId <- getNetworkId + sellerPayAddr <- withKeyWallet seller do + sellerPkh <- liftedM "Cannot get seller pkh" ownPaymentPubKeyHash + liftContractM "Could not get seller payment address" $ + payPubKeyHashEnterpriseAddress networkId sellerPkh + _ /\ nftData <- withKeyWallet seller do + cnft <- callMintCnft + callMintSgNft cnft mintParams + withKeyWallet buyer do + buyerAddr <- liftedM "Could not get buyer addr" getWalletAddress + mpScriptAddr <- marketplaceValidatorAddr + let + buyTestData = + { authorPayAddr: sellerPayAddr + , sellerPayAddr + , buyerAddr + , mpScriptAddr + , mintParams + } + withAssertions (getAssertions buyTestData) do + txHash /\ txData <- marketplaceBuy' retBehaviour nftData + awaitTxConfirmed txHash + sequence_ (getAfterAssertions { buyTestData, txData }) + + pure unit diff --git a/test/Contract/Minting.purs b/test/Contract/Minting.purs index edee340..86bfc68 100644 --- a/test/Contract/Minting.purs +++ b/test/Contract/Minting.purs @@ -23,7 +23,7 @@ import Test.Contract.Util , findUtxoWithNft , mintParams1 , plutipConfig - , privateStakeKey + , privateStakeKey1 ) import TestM (TestPlanM) @@ -32,7 +32,7 @@ suite = test "Minting" do let distribution = - ( withStakeKey privateStakeKey + ( withStakeKey privateStakeKey1 [ BigInt.fromInt 1_000_000_000 , BigInt.fromInt 2_000_000_000 ] diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 86eff6d..c03c7ab 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -1,5 +1,6 @@ module Test.Contract.Util - ( assertContract + ( ContractWrapAssertion + , assertContract , assertLovelaceChangeAtAddr , assertLovelaceDecAtAddr , assertLovelaceIncAtAddr @@ -9,8 +10,13 @@ module Test.Contract.Util , checkNftAtAddress , findUtxoWithNft , mintParams1 + , mintParams2 + , mintParams3 + , mintParams4 , plutipConfig - , privateStakeKey + , privateStakeKey1 + , privateStakeKey2 + , privateStakeKey3 , valueAtAddress , valueToLovelace , withAssertions @@ -44,6 +50,7 @@ import Effect.Exception (throw) import Partial.Unsafe (unsafePartial) import Seabug.Contract.CnftMint (mintCnft) import Seabug.Contract.Mint (mintWithCollection') +import Seabug.Contract.Util (modify) import Seabug.Types (MintCnftParams(..), MintParams, NftData) import Types.BigNum as BigNum import Types.RawBytes (hexToRawBytes) @@ -58,6 +65,17 @@ mintParams1 = wrap , feeVaultKeys: [] } +mintParams2 :: MintParams +mintParams2 = modify (_ { daoShare = Nat.fromInt' 10 }) mintParams1 + +mintParams3 :: MintParams +mintParams3 = modify (_ { authorShare = Nat.fromInt' 10 }) mintParams1 + +mintParams4 :: MintParams +mintParams4 = modify + (_ { daoShare = Nat.fromInt' 10, authorShare = Nat.fromInt' 10 }) + mintParams1 + callMintCnft ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) callMintCnft = do @@ -94,7 +112,7 @@ plutipConfig :: PlutipConfig plutipConfig = { host: "127.0.0.1" , port: UInt.fromInt 8082 - , logLevel: Trace + , logLevel: Error , ogmiosConfig: { port: UInt.fromInt 1338 , host: "127.0.0.1" @@ -116,17 +134,28 @@ plutipConfig = , postgresConfig: { host: "127.0.0.1" , port: UInt.fromInt 5433 - , user: "ctxlib" - , password: "ctxlib" - , dbname: "ctxlib" + , user: "seabugTests" + , password: "seabugTests" + , dbname: "seabugTests" } } -privateStakeKey :: PrivateStakeKey -privateStakeKey = wrap $ unsafePartial $ fromJust +privateStakeKeyFromStr :: String -> PrivateStakeKey +privateStakeKeyFromStr s = wrap $ unsafePartial $ fromJust $ privateKeyFromBytes - =<< hexToRawBytes - "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" + =<< hexToRawBytes s + +privateStakeKey1 :: PrivateStakeKey +privateStakeKey1 = privateStakeKeyFromStr + "633b1c4c4a075a538d37e062c1ed0706d3f0a94b013708e8f5ab0a0ca1df163d" + +privateStakeKey2 :: PrivateStakeKey +privateStakeKey2 = privateStakeKeyFromStr + "8ad4245e25152bbd9de44257c7a2a5f625d92f43ae54ae74716e6ad58e32d42e" + +privateStakeKey3 :: PrivateStakeKey +privateStakeKey3 = privateStakeKeyFromStr + "caff25cdb2c64d8edd4405ca62fa1d1641545890d3f1eb52be44317056216126" assertContract :: forall (r :: Row Type). String -> Boolean -> Contract r Unit assertContract msg cond = if cond then pure unit else liftEffect $ throw msg @@ -162,7 +191,7 @@ valueAtAddress address = utxosAt address <#> map -- | the result of passing to `check` the total value at the address -- | `addr` (named `addrName`) before and after calling `contract`. checkBalanceChangeAtAddr - :: forall (r :: Row Type) a b + :: forall (r :: Row Type) (a :: Type) (b :: Type) . String -> Address -> (Value -> Value -> Contract r b) @@ -181,7 +210,7 @@ checkBalanceChangeAtAddr addrName addr check contract = do -- | `actual` is the lovelace at `addr` after `contract` minus the -- | lovelace before. assertLovelaceChangeAtAddr - :: forall (r :: Row Type) a + :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt @@ -204,7 +233,7 @@ assertLovelaceChangeAtAddr addrName addr expected comp contract = -- | Requires that at least the passed amount of lovelace was gained -- | at the address by calling the contract. assertLovelaceIncAtAddr - :: forall (r :: Row Type) a + :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt @@ -216,7 +245,7 @@ assertLovelaceIncAtAddr addrName addr minGain contract = -- | Requires that at least the passed amount of lovelace was lost at -- | the address by calling the contract. assertLovelaceDecAtAddr - :: forall (r :: Row Type) a + :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt @@ -225,10 +254,12 @@ assertLovelaceDecAtAddr assertLovelaceDecAtAddr addrName addr minLoss contract = assertLovelaceChangeAtAddr addrName addr (negate minLoss) (<=) contract +type ContractWrapAssertion (r :: Row Type) = Contract r Unit -> Contract r Unit + -- | Composes assertions to be run with a contract. withAssertions - :: forall (r :: Row Type) a - . Array (Contract r Unit -> Contract r Unit) + :: forall (r :: Row Type) (a :: Type) + . Array (ContractWrapAssertion r) -> Contract r a -> Contract r Unit withAssertions assertions contract = ala Endo foldMap assertions (void contract) From 4fcdaf805ddacbbe752f8283c87ad4ee87efad08 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Wed, 17 Aug 2022 16:09:44 -0600 Subject: [PATCH 11/27] Update token policy and buy contract so buyer must pay full price Token policy of: https://github.com/mlabs-haskell/plutus-use-cases/commit/4f866cc98dab5526bd6fc1c4920f2a4eb2b98b31 --- src/Seabug/Contract/Util.purs | 25 ++++++++++++++++++++----- src/Seabug/MintingPolicy.js | 3 +-- 2 files changed, 21 insertions(+), 7 deletions(-) diff --git a/src/Seabug/Contract/Util.purs b/src/Seabug/Contract/Util.purs index abd18d9..67dfcff 100644 --- a/src/Seabug/Contract/Util.purs +++ b/src/Seabug/Contract/Util.purs @@ -10,7 +10,7 @@ module Seabug.Contract.Util import Contract.Prelude -import Contract.Address (getNetworkId) +import Contract.Address (getNetworkId, toPubKeyHash, toValidatorHash) import Contract.AuxiliaryData (setTxMetadata) import Contract.Monad (Contract, liftContractM, liftedE, liftedM) import Contract.Numeric.Natural (toBigInt) @@ -18,6 +18,7 @@ import Contract.PlutusData ( Datum(Datum) , Redeemer(Redeemer) , toData + , unitDatum , unitRedeemer ) import Contract.ScriptLookups @@ -35,20 +36,22 @@ import Contract.ScriptLookups import Contract.Scripts (typedValidatorEnterpriseAddress) import Contract.Transaction ( TransactionHash - , TransactionOutput(TransactionOutput) + , TransactionOutput(..) , balanceAndSignTxE , submit ) import Contract.TxConstraints ( TxConstraints , mustMintValueWithRedeemer + , mustPayToPubKey , mustPayToScript , mustSpendScriptOutput ) import Contract.Utxos (utxosAt) -import Contract.Value (CurrencySymbol) +import Contract.Value (CurrencySymbol, coinToValue, valueToCoin) import Contract.Value as Value import Contract.Wallet (getWalletAddress) +import Control.Alt ((<|>)) import Data.Array (find) as Array import Data.Bifunctor (lmap) import Data.BigInt (BigInt) @@ -194,14 +197,18 @@ mkChangeNftIdTxData name act mapNft (NftData nftData) mScriptUtxos = do liftedM (name <> ": Cannot get user Utxos") $ utxosAt userAddr Just scriptUtxos -> pure scriptUtxos + continueAdaConstraint <- + liftContractM "Could not tell where to continue the ada of the nft utxo" + $ mustContinueAdaOfUtxo utxoIndex let lookups = mconcat [ ScriptLookups.mintingPolicy policy , ScriptLookups.unspentOutputs $ Map.singleton utxo utxoIndex ] - constraints = mustMintValueWithRedeemer mintRedeemer - (newNftValue <> oldNftValue) + constraints = + mustMintValueWithRedeemer mintRedeemer (newNftValue <> oldNftValue) + <> continueAdaConstraint pure { constraints: constraints @@ -212,6 +219,14 @@ mkChangeNftIdTxData name act mapNft (NftData nftData) mScriptUtxos = do , newNft: newNft } +mustContinueAdaOfUtxo :: TransactionOutput -> Maybe (TxConstraints Void Void) +mustContinueAdaOfUtxo (TransactionOutput { address, amount }) = do + let adaValue = coinToValue $ valueToCoin amount + constraint <- + (flip mustPayToScript unitDatum <$> toValidatorHash address) + <|> (mustPayToPubKey <<< wrap <$> toPubKeyHash address) + pure $ constraint adaValue + minAdaOnlyUTxOValue :: BigInt minAdaOnlyUTxOValue = BigInt.fromInt 2_000_000 diff --git a/src/Seabug/MintingPolicy.js b/src/Seabug/MintingPolicy.js index bf5347d..23da312 100644 --- a/src/Seabug/MintingPolicy.js +++ b/src/Seabug/MintingPolicy.js @@ -1,7 +1,6 @@ exports._mintingPolicy = { mintingPolicy: { getMintingPolicy: - "59130e01000032333222323232323233223233223232332232323233322233322233322233223233322232323232332232333332222232323333333322222222333322223322332233223322332233223322332232323232323232323232323232323233333222223322222222322323232323223232533530713300a3333573466e1d40112000230473066500623333573466e1d401520062304b3067500723333573466e1d4019200223304a30685008306f500923333573466e1d401d200423304c30695009375ca014464c6a60d666ae701b41b01a81a41a019c198cccd5cd19b8735573aa004900011980999191919191919191919191999ab9a3370e6aae754029200023333333333035335025232323333573466e1cd55cea80124000466076605c6ae854008c0a8d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500a33502502635742a012666aa050eb9409cd5d0a804199aa8143ae502735742a00e66a04a05c6ae854018cd4094cd540c40bdd69aba150053232323333573466e1cd55cea80124000466a0866464646666ae68cdc39aab9d5002480008cd412ccd40d1d69aba150023035357426ae8940088c98d4c1f0cd5ce03f03e83d83d09aab9e5001137540026ae854008c8c8c8cccd5cd19b8735573aa0049000119a82499a81a3ad35742a004606a6ae84d5d1280111931a983e19ab9c07e07d07b07a135573ca00226ea8004d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500433502575c6ae85400ccd4094cd540c5d710009aba15002302b357426ae8940088c98d4c1d0cd5ce03b03a83983909aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aab9e5001137540026ae854008c8c8c8cccd5cd19b875001480188c070c098d5d09aab9e500323333573466e1d400920042301b3028357426aae7940108cccd5cd19b875003480088c06cc090d5d09aab9e500523333573466e1d401120002301e375c6ae84d55cf280311931a983799ab9c07107006e06d06c06b06a135573aa00226ea8004d5d09aba2500223263530683357380d40d20ce0cc20d0264c6a60ce66ae7124010350543500068066135573ca00226ea80044d55cea80209aba150021357426ae8940044d55cf280089baa001333333222222223232323232323235302c3530160082200222222222223233335305501425335308201533530820133353061120012235355040002223535504200322533530880133078004002133077003001108901335063335503f305e001337020fc90012832299a9a83418078011080089931a983c19ab9c49010b756e726561636861626c65000790771084011335738921124e4654206d757374206265206275726e6564000830115335308201533530820133037501135307b00122200110840113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e000830115335308201333553055120013505b50732533530830153353083013306635303d00122200333068307001b506a1084011085011333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011f556e6465726c79696e67204e4654206d75737420626520756e6c6f636b656400083011083011083012323232323225335308801533530880133301300735308101007222002001108a0113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e740008901153353088015335308801333573466e1cd4c2040401c88800821004228042240442280454cd4c22004cc015400ccc1b4c1d407541bc54cd4c22004cc0154008cc1b4c1d807d41bc4ccd54c16c48004d418541e4cc018cc1b4c1d8d4c2040401c88800541bccdc099b815004308501500230850150035016108901108901108a01133573892113526f79616c6974696573206e6f742070616964000890110890113370666e09400807120a09c0113370666e09400406520a09c01135307d003222002225335308501333573466e2000820c0421c0421804421c044ccd54c16048004d417941d8cc00c004009404c888d4c0fc0048894cd4c22004cc1ac01800c54cd4c22004ccd5cd19b8700533303c00206506508a0108901153353506e53353506e0012132353040001222222222253353507a333553067120015066235355051001225335309701333573466e3c00803c26404260044d41fc00c541f800884d41f4d4d5414400488004541ed4060541bc84c8ccd5cd19baf00200108c0108b013235355046001223374a900019aba0375200466ae80dd48009bb1081013355046501a3065008108901108901108901225335308301533530830133300e00200135307c00222200110850113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e7400084011533530830133038501235307c00222200110850113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e0008401108401253353082015335308201533535062533535068301200221001132635307833573892010b756e726561636861626c6500079077108301221353550400022253353506600315335308601333573466e3c008c1880142200421c044ccd5cd19b87001480082200421c04421c04884224044210044cd5ce2491e45786163746c79206f6e65204e4654206d757374206265206d696e746564000830115335308201333553055120013505b5073253353083013306635303d00122200333068307001b506a1333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011d556e6465726c79696e67204e4654206d757374206265206c6f636b65640008301108301353036500f222222222200723222325335350605335350603006353030500922222222220072135063001150612153353505b001107c221353550390022253353505f0031080012213535503d0022253353506300315335308301533530830133073006500d133073002500a10840115335308301333573466e1c015200108501084011333573466e1c0052002085010840110840115335308301533530830133073002500d133073006500a10840115335308301333573466e1c005200108501084011333573466e1c0152002085010840110840110840122108601107b130553530720042223330760030050041305200132001355077225335350560011505d22135355034002225335307a3306a002500b1350620011300600332001355076225335350550011505c22135355033002225335307933069002500a1350610011300600313530285001222222222200913530110032200232001355073225335350520011505922135355030002225335307633066002500713505e00113006003135300f001223333530130012326353068335738921024c6800069067200123263530683357389201024c680006906723263530683357389201024c6800069067375c00c6eb8014dd700218310019bae00230620012212330010030022001212222300400521222230030052122223002005212222300100520011232230023758002640026aa0ba446666aae7c004940fc8cd40f8c010d5d080118019aba200205323232323333573466e1cd55cea801a400046660306464646666ae68cdc39aab9d5002480008cc118c04cd5d0a80119a8060091aba135744a004464c6a60ae66ae701641601581544d55cf280089baa00135742a006666aa00eeb94018d5d0a80119a8043ae357426ae8940088c98d4c14ccd5ce02a82a02902889aba25001135573ca00226ea80044cd54005d73ad112232230023756002640026aa0b644646666aae7c008940f88cd40f4cd54064c018d55cea80118029aab9e50023004357440060a426ae84004488c8c8cccd5cd19b875001480008d4108c014d5d09aab9e500323333573466e1d400920022504223263530513357380a60a40a009e09c26aae7540044dd5000919191999ab9a3370e6aae7540092000233017300535742a0046eb4d5d09aba25002232635304e3357380a009e09a09826aae7940044dd50009191999ab9a3370e6aae75400520002375c6ae84d55cf280111931a982619ab9c04e04d04b04a1375400224464646666ae68cdc3a800a40084a03c46666ae68cdc3a8012400446a042600c6ae84d55cf280211999ab9a3370ea00690001281091931a982799ab9c05105004e04d04c04b135573aa00226ea80048c8cccd5cd19b8750014800881588cccd5cd19b8750024800081588c98d4c12ccd5ce02682602502482409aab9d3754002464646464646666ae68cdc3a800a4018404846666ae68cdc3a80124014404c46666ae68cdc3a801a40104660486eb8d5d0a8029bad357426ae8940148cccd5cd19b875004480188cc098dd71aba15007375c6ae84d5d1280391999ab9a3370ea00a900211981598061aba15009375c6ae84d5d1280491999ab9a3370ea00c90011181698069aba135573ca01646666ae68cdc3a803a400046058601c6ae84d55cf280611931a982999ab9c05505405205105004f04e04d04c04b135573aa00826aae79400c4d55cf280109aab9e5001137540024646464646666ae68cdc3a800a4004466607e6eb4d5d0a8021bad35742a0066eb4d5d09aba2500323333573466e1d40092000230413008357426aae7940188c98d4c130cd5ce02702682582502489aab9d5003135744a00226aae7940044dd5000919191999ab9a3370ea00290011181f9bae357426aae79400c8cccd5cd19b875002480008c104dd71aba135573ca008464c6a609266ae7012c12812011c1184d55cea80089baa0011122232323333573466e1cd55cea80124000466aa020600c6ae854008c014d5d09aba25002232635304933573809609409008e26aae7940044dd500091119191800802990009aa8299119a9a819000a4000446a6aa02000444a66a60ac666ae68cdc780100482c02b8980380089803001990009aa8291119a9a818800a4000446a6aa01e00444a66a60aa666ae68cdc780100382b82b080089803001911a98018011111111111299a9a81e999aa981509000a8149299a982c199ab9a3371e0180020b40b226a0800022a07e006420b420b0444444444424666666666600201601401201000e00c00a008006004400244246600200600440024442466600200800600440022244246600200600422400244246600200600440022442466002006004240022442466002006004240022442466002006004240022424446006008224440042244400224002424444444600e01044244444446600c012010424444444600a01024444444008244444440064424444444660040120104424444444660020120104002266a01244a66a6a02c004420062002a02a640026aa0604422444a66a6a02400226a6a01800644002442666a6a01c00a440046008004666aa600e2400200a008002424444600800a44244446600600c00a44244446600400c00a424444600200a40022466a00644666a6a038006440040040026a6a0340024400224424660020060042400246e50ccd54c00c48005c5001199119801191b94330270010053530200032220023300237286a6040006444002660046e50d4c08000c88800c0054019401d22010032001355025221122253353500700110022213300500233355300712001005004001320013550242212225335350060021533535006001102822102922153353500800310292215335302a3300700400213335300912001007003001102b1122002122122330010040031200122353003002223530050032232335301000523353011004253353026333573466e3c0080040a009c5400c409c809c8cd4c044010809c94cd4c098ccd5cd19b8f00200102802715003102715335350090032153353500a00221335300e0022335300f0022335301300223353014002233019002001202a23353014002202a23301900200122202a2223353011004202a2225335302b333573466e1c01800c0b40b054cd4c0acccd5cd19b8700500202d02c13301a004001102c102c1025153353500900121025102522123300100300220011212230020031122001120012122300200322212233300100500400320012122300200321223001003200122333573466e1c00800405405088ccd5cd19b8f002001014013133500222533530110021013100101012212330010030021200123232323333573466e1cd55cea801a400046660166eb8d5d0a80198061aba15002375c6ae84d5d1280111931a980399ab9c009008006005135744a00226aae7940044dd5000a4c2400240029201035054310022212333001004003002200123253353007333573466e21400400c02402058540044dd6800a40004a66a6008666ae68cdc40008010030028a400020029040497a00990009aa802111299a9802199ab9a33710004904002003002899b8b0020011330033370600490400219b8b3370c0049040020008910010910009000889191800800911980198010010009" + "5913b401000032333222323232323233223233223232332232323233322233322233322233223233322232323232332232333332222232323333333322222222333322223322332233223322332233223322332232323232323232323232323232323233333222223322222222322323232323223232533530713300a3333573466e1d40112000230473066500623333573466e1d401520062304b3067500723333573466e1d4019200223304a30685008306f500923333573466e1d401d200423304c30695009375ca014464c6a60d666ae701b41b01a81a41a019c198cccd5cd19b8735573aa004900011980999191919191919191919191999ab9a3370e6aae754029200023333333333035335025232323333573466e1cd55cea80124000466076605c6ae854008c0a8d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500a33502502635742a012666aa050eb9409cd5d0a804199aa8143ae502735742a00e66a04a05c6ae854018cd4094cd540c40bdd69aba150053232323333573466e1cd55cea80124000466a0866464646666ae68cdc39aab9d5002480008cd412ccd40d1d69aba150023035357426ae8940088c98d4c1f0cd5ce03f03e83d83d09aab9e5001137540026ae854008c8c8c8cccd5cd19b8735573aa0049000119a82499a81a3ad35742a004606a6ae84d5d1280111931a983e19ab9c07e07d07b07a135573ca00226ea8004d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500433502575c6ae85400ccd4094cd540c5d710009aba15002302b357426ae8940088c98d4c1d0cd5ce03b03a83983909aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aab9e5001137540026ae854008c8c8c8cccd5cd19b875001480188c070c098d5d09aab9e500323333573466e1d400920042301b3028357426aae7940108cccd5cd19b875003480088c06cc090d5d09aab9e500523333573466e1d401120002301e375c6ae84d55cf280311931a983799ab9c07107006e06d06c06b06a135573aa00226ea8004d5d09aba2500223263530683357380d40d20ce0cc20d0264c6a60ce66ae7124010350543500068066135573ca00226ea80044d55cea80209aba150021357426ae8940044d55cf280089baa001333333222222223232323232323235302c3530160082200222222222223233335305501425335308201533530820133353061120012235355040002223535504200322533530880133078004002133077003001108901335063335503f305e001337020fc90012832299a9a83418078011080089931a983c19ab9c49010b756e726561636861626c65000790771084011335738921124e4654206d757374206265206275726e6564000830115335308201533530820133037501135307b00122200110840113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e000830115335308201333553055120013505b50732533530830153353083013306635303d00122200333068307001b506a1084011085011333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011f556e6465726c79696e67204e4654206d75737420626520756e6c6f636b65640008301108301108301232323232322325335308901533530890133301400835308201008222002002108b0113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e740008a011533530890153353089013300650043306e307601e5070153353089013300650033306e307702050701533530890133355305c1200135062507a330073306e30773530820100822200150703370266e054014c21805400cc218054011405c4ccd5cd19b883370266a60022400246a6084002440026a607ea030444444444401466a6002240024002a02ea00a1140211602211402211402211402211602266ae71240112526f79616c74696573206e6f7420706169640008a01108a013200135508b01221223353506c001480008c88cdc019a980389000802800a99a98478099299a9a83b1a83c00490a99a9a83b9a983a8011119a983f80111a83e0009283d9099841008010008849008a99a9a83b1a983a0009119a983f00111a83d8009283d10849008849009a9824a80111100189998219a9824a8011110010360360a400026006002266e0ccdc1280100e241413802266e0ccdc1280080ca4141380226a60fa00644400444a66a610a02666ae68cdc40010418084380843008843808999aa982c090009a82f283b1980180080128099111a981f800911299a984400998358030018a99a984400999ab9a3370e00a6660780040ca0ca11402112022a66a6a0dca66a6a0dc00242646a60800024444444444a66a6a0f4666aa60ce24002a0cc46a6aa0a200244a66a612e02666ae68cdc780100784c8084c0089a83f8018a83f001109a83e9a9aa828800910008a83da80c0a8379099199ab9a3375e0040021180211602646a6aa08c0024466e9520003357406ea4008cd5d01ba900137621020266aa08ca03460ca01021120221120221120244a66a610602a66a61060266601c0040026a60f8004444002210a02266ae7124013e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e7400084011533530830133038501235307c00222200110850113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e0008401108401253353082015335308201533535062533535068301200221001132635307833573892010b756e726561636861626c6500079077108301221353550400022253353506600315335308601333573466e3c008c1880142200421c044ccd5cd19b87001480082200421c04421c04884224044210044cd5ce2491e45786163746c79206f6e65204e4654206d757374206265206d696e746564000830115335308201333553055120013505b5073253353083013306635303d00122200333068307001b506a1333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011d556e6465726c79696e67204e4654206d757374206265206c6f636b65640008301108301353036500f222222222200723222325335350605335350603006353030500922222222220072135063001150612153353505b001107c221353550390022253353505f0031080012213535503d0022253353506300315335308301533530830133073006500d133073002500a10840115335308301333573466e1c015200108501084011333573466e1c0052002085010840110840115335308301533530830133073002500d133073006500a10840115335308301333573466e1c005200108501084011333573466e1c0152002085010840110840110840122108601107b130553530720042223330760030050041305200132001355077225335350560011505d22135355034002225335307a3306a002500b1350620011300600332001355076225335350550011505c22135355033002225335307933069002500a1350610011300600313530285001222222222200913530110032200232001355073225335350520011505922135355030002225335307633066002500713505e00113006003135300f001223333530130012326353068335738921024c6800069067200123263530683357389201024c680006906723263530683357389201024c6800069067375c00c6eb8014dd700218310019bae00230620012212330010030022001212222300400521222230030052122223002005212222300100520011232230023758002640026aa0ba446666aae7c004940fc8cd40f8c010d5d080118019aba200205323232323333573466e1cd55cea801a400046660306464646666ae68cdc39aab9d5002480008cc118c04cd5d0a80119a8060091aba135744a004464c6a60ae66ae701641601581544d55cf280089baa00135742a006666aa00eeb94018d5d0a80119a8043ae357426ae8940088c98d4c14ccd5ce02a82a02902889aba25001135573ca00226ea80044cd54005d73ad112232230023756002640026aa0b644646666aae7c008940f88cd40f4cd54064c018d55cea80118029aab9e50023004357440060a426ae84004488c8c8cccd5cd19b875001480008d4108c014d5d09aab9e500323333573466e1d400920022504223263530513357380a60a40a009e09c26aae7540044dd5000919191999ab9a3370e6aae7540092000233017300535742a0046eb4d5d09aba25002232635304e3357380a009e09a09826aae7940044dd50009191999ab9a3370e6aae75400520002375c6ae84d55cf280111931a982619ab9c04e04d04b04a1375400224464646666ae68cdc3a800a40084a03c46666ae68cdc3a8012400446a042600c6ae84d55cf280211999ab9a3370ea00690001281091931a982799ab9c05105004e04d04c04b135573aa00226ea80048c8cccd5cd19b8750014800881588cccd5cd19b8750024800081588c98d4c12ccd5ce02682602502482409aab9d3754002464646464646666ae68cdc3a800a4018404846666ae68cdc3a80124014404c46666ae68cdc3a801a40104660486eb8d5d0a8029bad357426ae8940148cccd5cd19b875004480188cc098dd71aba15007375c6ae84d5d1280391999ab9a3370ea00a900211981598061aba15009375c6ae84d5d1280491999ab9a3370ea00c90011181698069aba135573ca01646666ae68cdc3a803a400046058601c6ae84d55cf280611931a982999ab9c05505405205105004f04e04d04c04b135573aa00826aae79400c4d55cf280109aab9e5001137540024646464646666ae68cdc3a800a4004466607e6eb4d5d0a8021bad35742a0066eb4d5d09aba2500323333573466e1d40092000230413008357426aae7940188c98d4c130cd5ce02702682582502489aab9d5003135744a00226aae7940044dd5000919191999ab9a3370ea00290011181f9bae357426aae79400c8cccd5cd19b875002480008c104dd71aba135573ca008464c6a609266ae7012c12812011c1184d55cea80089baa0011122232323333573466e1cd55cea80124000466aa020600c6ae854008c014d5d09aba25002232635304933573809609409008e26aae7940044dd500091119191800802990009aa8299119a9a819000a4000446a6aa02000444a66a60ac666ae68cdc780100482c02b8980380089803001990009aa8291119a9a818800a4000446a6aa01e00444a66a60aa666ae68cdc780100382b82b080089803001911a98018011111111111299a9a81e999aa981509000a8149299a982c199ab9a3371e0180020b40b226a0800022a07e006420b420b0444444444424666666666600201601401201000e00c00a008006004400244246600200600440024442466600200800600440022244246600200600422400244246600200600440022442466002006004240022442466002006004240022442466002006004240022424446006008224440042244400224002424444444600e01044244444446600c012010424444444600a01024444444008244444440064424444444660040120104424444444660020120104002266a01244a66a6a02c004420062002a02a640026aa0604422444a66a6a02400226a6a01800644002442666a6a01c00a440046008004666aa600e2400200a008002424444600800a44244446600600c00a44244446600400c00a424444600200a40022466a00644666a6a038006440040040026a6a0340024400224424660020060042400246e50ccd54c00c48005c5001199119801191b94330270010053530200032220023300237286a6040006444002660046e50d4c08000c88800c0054019401d22010032001355025221122253353500700110022213300500233355300712001005004001320013550242212225335350060021533535006001102822102922153353500800310292215335302a3300700400213335300912001007003001102b1122002122122330010040031200122353003002223530050032232335301000523353011004253353026333573466e3c0080040a009c5400c409c809c8cd4c044010809c94cd4c098ccd5cd19b8f00200102802715003102715335350090032153353500a00221335300e0022335300f0022335301300223353014002233019002001202a23353014002202a23301900200122202a2223353011004202a2225335302b333573466e1c01800c0b40b054cd4c0acccd5cd19b8700500202d02c13301a004001102c102c1025153353500900121025102522123300100300220011212230020031122001120012122300200322212233300100500400320012122300200321223001003200122333573466e1c00800405405088ccd5cd19b8f002001014013133500222533530110021013100101012212330010030021200123232323333573466e1cd55cea801a400046660166eb8d5d0a80198061aba15002375c6ae84d5d1280111931a980399ab9c009008006005135744a00226aae7940044dd5000a4c2400240029201035054310022212333001004003002200123253353007333573466e21400400c02402058540044dd6800a40004a66a6008666ae68cdc40008010030028a400020029040497a00990009aa802111299a9802199ab9a33710004904002003002899b8b0020011330033370600490400219b8b3370c0049040020008910010910009000889191800800911980198010010009" }, }; - From 386c847b9332d3165ad7663f4d5d5a57f9ae0671 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Wed, 17 Aug 2022 16:11:13 -0600 Subject: [PATCH 12/27] Update tests --- test/Contract/Buy.purs | 14 +++++++++----- test/Contract/Util.purs | 6 +++--- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index a14080f..bcb6105 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -17,7 +17,11 @@ import Data.BigInt (BigInt) import Data.BigInt as BigInt import Mote (group, only, skip, test) import Seabug.Contract.Buy (marketplaceBuy') -import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData) +import Seabug.Contract.Util + ( ReturnBehaviour(..) + , SeabugTxData + , minAdaOnlyUTxOValue + ) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (MintParams) import Test.Contract.Util @@ -109,14 +113,14 @@ suite = only $ group "Buy" do test "Seller is author, no low prices, nft to marketplace" $ mkBuyTest buyTestConfig1 - skip $ test "Seller is author, no low prices, nft to buyer" $ + test "Seller is author, no low prices, nft to buyer" $ mkBuyTest buyTestConfig1 { retBehaviour = ToCaller , postBuyAssertions = nftToBuyerAssert } test "Seller is author, low marketplace share, nft to marketplace" $ mkBuyTest buyTestConfig2 - skip $ test "Seller is author, low marketplace share, nft to buyer" $ + test "Seller is author, low marketplace share, nft to buyer" $ mkBuyTest buyTestConfig2 { retBehaviour = ToCaller , postBuyAssertions = nftToBuyerAssert @@ -165,10 +169,10 @@ mkShareAssertions let minBuyerLoss = Nat.toBigInt (unwrap mintParams).price in - [ assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain + [ assertLovelaceIncAtAddr "Author" authorPayAddr minAuthorGain , assertLovelaceIncAtAddr "Seller" sellerPayAddr minSellerGain - , assertLovelaceIncAtAddr "Author" authorPayAddr minAuthorGain , assertLovelaceDecAtAddr "Buyer" buyerAddr minBuyerLoss + , assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain ] runBuyTest diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index c03c7ab..fdf27d3 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -134,9 +134,9 @@ plutipConfig = , postgresConfig: { host: "127.0.0.1" , port: UInt.fromInt 5433 - , user: "seabugTests" - , password: "seabugTests" - , dbname: "seabugTests" + , user: "ctxlib" + , password: "ctxlib" + , dbname: "ctxlib" } } From f042c9788ae01a45b0bb16a4d781c5b9d870aed7 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Thu, 18 Aug 2022 10:32:59 -0600 Subject: [PATCH 13/27] Revert "Update token policy and buy contract so buyer must pay full price" This reverts commit 4fcdaf805ddacbbe752f8283c87ad4ee87efad08. --- src/Seabug/Contract/Util.purs | 25 +++++-------------------- src/Seabug/MintingPolicy.js | 2 +- 2 files changed, 6 insertions(+), 21 deletions(-) diff --git a/src/Seabug/Contract/Util.purs b/src/Seabug/Contract/Util.purs index 67dfcff..abd18d9 100644 --- a/src/Seabug/Contract/Util.purs +++ b/src/Seabug/Contract/Util.purs @@ -10,7 +10,7 @@ module Seabug.Contract.Util import Contract.Prelude -import Contract.Address (getNetworkId, toPubKeyHash, toValidatorHash) +import Contract.Address (getNetworkId) import Contract.AuxiliaryData (setTxMetadata) import Contract.Monad (Contract, liftContractM, liftedE, liftedM) import Contract.Numeric.Natural (toBigInt) @@ -18,7 +18,6 @@ import Contract.PlutusData ( Datum(Datum) , Redeemer(Redeemer) , toData - , unitDatum , unitRedeemer ) import Contract.ScriptLookups @@ -36,22 +35,20 @@ import Contract.ScriptLookups import Contract.Scripts (typedValidatorEnterpriseAddress) import Contract.Transaction ( TransactionHash - , TransactionOutput(..) + , TransactionOutput(TransactionOutput) , balanceAndSignTxE , submit ) import Contract.TxConstraints ( TxConstraints , mustMintValueWithRedeemer - , mustPayToPubKey , mustPayToScript , mustSpendScriptOutput ) import Contract.Utxos (utxosAt) -import Contract.Value (CurrencySymbol, coinToValue, valueToCoin) +import Contract.Value (CurrencySymbol) import Contract.Value as Value import Contract.Wallet (getWalletAddress) -import Control.Alt ((<|>)) import Data.Array (find) as Array import Data.Bifunctor (lmap) import Data.BigInt (BigInt) @@ -197,18 +194,14 @@ mkChangeNftIdTxData name act mapNft (NftData nftData) mScriptUtxos = do liftedM (name <> ": Cannot get user Utxos") $ utxosAt userAddr Just scriptUtxos -> pure scriptUtxos - continueAdaConstraint <- - liftContractM "Could not tell where to continue the ada of the nft utxo" - $ mustContinueAdaOfUtxo utxoIndex let lookups = mconcat [ ScriptLookups.mintingPolicy policy , ScriptLookups.unspentOutputs $ Map.singleton utxo utxoIndex ] - constraints = - mustMintValueWithRedeemer mintRedeemer (newNftValue <> oldNftValue) - <> continueAdaConstraint + constraints = mustMintValueWithRedeemer mintRedeemer + (newNftValue <> oldNftValue) pure { constraints: constraints @@ -219,14 +212,6 @@ mkChangeNftIdTxData name act mapNft (NftData nftData) mScriptUtxos = do , newNft: newNft } -mustContinueAdaOfUtxo :: TransactionOutput -> Maybe (TxConstraints Void Void) -mustContinueAdaOfUtxo (TransactionOutput { address, amount }) = do - let adaValue = coinToValue $ valueToCoin amount - constraint <- - (flip mustPayToScript unitDatum <$> toValidatorHash address) - <|> (mustPayToPubKey <<< wrap <$> toPubKeyHash address) - pure $ constraint adaValue - minAdaOnlyUTxOValue :: BigInt minAdaOnlyUTxOValue = BigInt.fromInt 2_000_000 diff --git a/src/Seabug/MintingPolicy.js b/src/Seabug/MintingPolicy.js index 23da312..489bbac 100644 --- a/src/Seabug/MintingPolicy.js +++ b/src/Seabug/MintingPolicy.js @@ -1,6 +1,6 @@ exports._mintingPolicy = { mintingPolicy: { getMintingPolicy: - "5913b401000032333222323232323233223233223232332232323233322233322233322233223233322232323232332232333332222232323333333322222222333322223322332233223322332233223322332232323232323232323232323232323233333222223322222222322323232323223232533530713300a3333573466e1d40112000230473066500623333573466e1d401520062304b3067500723333573466e1d4019200223304a30685008306f500923333573466e1d401d200423304c30695009375ca014464c6a60d666ae701b41b01a81a41a019c198cccd5cd19b8735573aa004900011980999191919191919191919191999ab9a3370e6aae754029200023333333333035335025232323333573466e1cd55cea80124000466076605c6ae854008c0a8d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500a33502502635742a012666aa050eb9409cd5d0a804199aa8143ae502735742a00e66a04a05c6ae854018cd4094cd540c40bdd69aba150053232323333573466e1cd55cea80124000466a0866464646666ae68cdc39aab9d5002480008cd412ccd40d1d69aba150023035357426ae8940088c98d4c1f0cd5ce03f03e83d83d09aab9e5001137540026ae854008c8c8c8cccd5cd19b8735573aa0049000119a82499a81a3ad35742a004606a6ae84d5d1280111931a983e19ab9c07e07d07b07a135573ca00226ea8004d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500433502575c6ae85400ccd4094cd540c5d710009aba15002302b357426ae8940088c98d4c1d0cd5ce03b03a83983909aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aab9e5001137540026ae854008c8c8c8cccd5cd19b875001480188c070c098d5d09aab9e500323333573466e1d400920042301b3028357426aae7940108cccd5cd19b875003480088c06cc090d5d09aab9e500523333573466e1d401120002301e375c6ae84d55cf280311931a983799ab9c07107006e06d06c06b06a135573aa00226ea8004d5d09aba2500223263530683357380d40d20ce0cc20d0264c6a60ce66ae7124010350543500068066135573ca00226ea80044d55cea80209aba150021357426ae8940044d55cf280089baa001333333222222223232323232323235302c3530160082200222222222223233335305501425335308201533530820133353061120012235355040002223535504200322533530880133078004002133077003001108901335063335503f305e001337020fc90012832299a9a83418078011080089931a983c19ab9c49010b756e726561636861626c65000790771084011335738921124e4654206d757374206265206275726e6564000830115335308201533530820133037501135307b00122200110840113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e000830115335308201333553055120013505b50732533530830153353083013306635303d00122200333068307001b506a1084011085011333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011f556e6465726c79696e67204e4654206d75737420626520756e6c6f636b65640008301108301108301232323232322325335308901533530890133301400835308201008222002002108b0113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e740008a011533530890153353089013300650043306e307601e5070153353089013300650033306e307702050701533530890133355305c1200135062507a330073306e30773530820100822200150703370266e054014c21805400cc218054011405c4ccd5cd19b883370266a60022400246a6084002440026a607ea030444444444401466a6002240024002a02ea00a1140211602211402211402211402211602266ae71240112526f79616c74696573206e6f7420706169640008a01108a013200135508b01221223353506c001480008c88cdc019a980389000802800a99a98478099299a9a83b1a83c00490a99a9a83b9a983a8011119a983f80111a83e0009283d9099841008010008849008a99a9a83b1a983a0009119a983f00111a83d8009283d10849008849009a9824a80111100189998219a9824a8011110010360360a400026006002266e0ccdc1280100e241413802266e0ccdc1280080ca4141380226a60fa00644400444a66a610a02666ae68cdc40010418084380843008843808999aa982c090009a82f283b1980180080128099111a981f800911299a984400998358030018a99a984400999ab9a3370e00a6660780040ca0ca11402112022a66a6a0dca66a6a0dc00242646a60800024444444444a66a6a0f4666aa60ce24002a0cc46a6aa0a200244a66a612e02666ae68cdc780100784c8084c0089a83f8018a83f001109a83e9a9aa828800910008a83da80c0a8379099199ab9a3375e0040021180211602646a6aa08c0024466e9520003357406ea4008cd5d01ba900137621020266aa08ca03460ca01021120221120221120244a66a610602a66a61060266601c0040026a60f8004444002210a02266ae7124013e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e7400084011533530830133038501235307c00222200110850113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e0008401108401253353082015335308201533535062533535068301200221001132635307833573892010b756e726561636861626c6500079077108301221353550400022253353506600315335308601333573466e3c008c1880142200421c044ccd5cd19b87001480082200421c04421c04884224044210044cd5ce2491e45786163746c79206f6e65204e4654206d757374206265206d696e746564000830115335308201333553055120013505b5073253353083013306635303d00122200333068307001b506a1333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011d556e6465726c79696e67204e4654206d757374206265206c6f636b65640008301108301353036500f222222222200723222325335350605335350603006353030500922222222220072135063001150612153353505b001107c221353550390022253353505f0031080012213535503d0022253353506300315335308301533530830133073006500d133073002500a10840115335308301333573466e1c015200108501084011333573466e1c0052002085010840110840115335308301533530830133073002500d133073006500a10840115335308301333573466e1c005200108501084011333573466e1c0152002085010840110840110840122108601107b130553530720042223330760030050041305200132001355077225335350560011505d22135355034002225335307a3306a002500b1350620011300600332001355076225335350550011505c22135355033002225335307933069002500a1350610011300600313530285001222222222200913530110032200232001355073225335350520011505922135355030002225335307633066002500713505e00113006003135300f001223333530130012326353068335738921024c6800069067200123263530683357389201024c680006906723263530683357389201024c6800069067375c00c6eb8014dd700218310019bae00230620012212330010030022001212222300400521222230030052122223002005212222300100520011232230023758002640026aa0ba446666aae7c004940fc8cd40f8c010d5d080118019aba200205323232323333573466e1cd55cea801a400046660306464646666ae68cdc39aab9d5002480008cc118c04cd5d0a80119a8060091aba135744a004464c6a60ae66ae701641601581544d55cf280089baa00135742a006666aa00eeb94018d5d0a80119a8043ae357426ae8940088c98d4c14ccd5ce02a82a02902889aba25001135573ca00226ea80044cd54005d73ad112232230023756002640026aa0b644646666aae7c008940f88cd40f4cd54064c018d55cea80118029aab9e50023004357440060a426ae84004488c8c8cccd5cd19b875001480008d4108c014d5d09aab9e500323333573466e1d400920022504223263530513357380a60a40a009e09c26aae7540044dd5000919191999ab9a3370e6aae7540092000233017300535742a0046eb4d5d09aba25002232635304e3357380a009e09a09826aae7940044dd50009191999ab9a3370e6aae75400520002375c6ae84d55cf280111931a982619ab9c04e04d04b04a1375400224464646666ae68cdc3a800a40084a03c46666ae68cdc3a8012400446a042600c6ae84d55cf280211999ab9a3370ea00690001281091931a982799ab9c05105004e04d04c04b135573aa00226ea80048c8cccd5cd19b8750014800881588cccd5cd19b8750024800081588c98d4c12ccd5ce02682602502482409aab9d3754002464646464646666ae68cdc3a800a4018404846666ae68cdc3a80124014404c46666ae68cdc3a801a40104660486eb8d5d0a8029bad357426ae8940148cccd5cd19b875004480188cc098dd71aba15007375c6ae84d5d1280391999ab9a3370ea00a900211981598061aba15009375c6ae84d5d1280491999ab9a3370ea00c90011181698069aba135573ca01646666ae68cdc3a803a400046058601c6ae84d55cf280611931a982999ab9c05505405205105004f04e04d04c04b135573aa00826aae79400c4d55cf280109aab9e5001137540024646464646666ae68cdc3a800a4004466607e6eb4d5d0a8021bad35742a0066eb4d5d09aba2500323333573466e1d40092000230413008357426aae7940188c98d4c130cd5ce02702682582502489aab9d5003135744a00226aae7940044dd5000919191999ab9a3370ea00290011181f9bae357426aae79400c8cccd5cd19b875002480008c104dd71aba135573ca008464c6a609266ae7012c12812011c1184d55cea80089baa0011122232323333573466e1cd55cea80124000466aa020600c6ae854008c014d5d09aba25002232635304933573809609409008e26aae7940044dd500091119191800802990009aa8299119a9a819000a4000446a6aa02000444a66a60ac666ae68cdc780100482c02b8980380089803001990009aa8291119a9a818800a4000446a6aa01e00444a66a60aa666ae68cdc780100382b82b080089803001911a98018011111111111299a9a81e999aa981509000a8149299a982c199ab9a3371e0180020b40b226a0800022a07e006420b420b0444444444424666666666600201601401201000e00c00a008006004400244246600200600440024442466600200800600440022244246600200600422400244246600200600440022442466002006004240022442466002006004240022442466002006004240022424446006008224440042244400224002424444444600e01044244444446600c012010424444444600a01024444444008244444440064424444444660040120104424444444660020120104002266a01244a66a6a02c004420062002a02a640026aa0604422444a66a6a02400226a6a01800644002442666a6a01c00a440046008004666aa600e2400200a008002424444600800a44244446600600c00a44244446600400c00a424444600200a40022466a00644666a6a038006440040040026a6a0340024400224424660020060042400246e50ccd54c00c48005c5001199119801191b94330270010053530200032220023300237286a6040006444002660046e50d4c08000c88800c0054019401d22010032001355025221122253353500700110022213300500233355300712001005004001320013550242212225335350060021533535006001102822102922153353500800310292215335302a3300700400213335300912001007003001102b1122002122122330010040031200122353003002223530050032232335301000523353011004253353026333573466e3c0080040a009c5400c409c809c8cd4c044010809c94cd4c098ccd5cd19b8f00200102802715003102715335350090032153353500a00221335300e0022335300f0022335301300223353014002233019002001202a23353014002202a23301900200122202a2223353011004202a2225335302b333573466e1c01800c0b40b054cd4c0acccd5cd19b8700500202d02c13301a004001102c102c1025153353500900121025102522123300100300220011212230020031122001120012122300200322212233300100500400320012122300200321223001003200122333573466e1c00800405405088ccd5cd19b8f002001014013133500222533530110021013100101012212330010030021200123232323333573466e1cd55cea801a400046660166eb8d5d0a80198061aba15002375c6ae84d5d1280111931a980399ab9c009008006005135744a00226aae7940044dd5000a4c2400240029201035054310022212333001004003002200123253353007333573466e21400400c02402058540044dd6800a40004a66a6008666ae68cdc40008010030028a400020029040497a00990009aa802111299a9802199ab9a33710004904002003002899b8b0020011330033370600490400219b8b3370c0049040020008910010910009000889191800800911980198010010009" + "59130e01000032333222323232323233223233223232332232323233322233322233322233223233322232323232332232333332222232323333333322222222333322223322332233223322332233223322332232323232323232323232323232323233333222223322222222322323232323223232533530713300a3333573466e1d40112000230473066500623333573466e1d401520062304b3067500723333573466e1d4019200223304a30685008306f500923333573466e1d401d200423304c30695009375ca014464c6a60d666ae701b41b01a81a41a019c198cccd5cd19b8735573aa004900011980999191919191919191919191999ab9a3370e6aae754029200023333333333035335025232323333573466e1cd55cea80124000466076605c6ae854008c0a8d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500a33502502635742a012666aa050eb9409cd5d0a804199aa8143ae502735742a00e66a04a05c6ae854018cd4094cd540c40bdd69aba150053232323333573466e1cd55cea80124000466a0866464646666ae68cdc39aab9d5002480008cd412ccd40d1d69aba150023035357426ae8940088c98d4c1f0cd5ce03f03e83d83d09aab9e5001137540026ae854008c8c8c8cccd5cd19b8735573aa0049000119a82499a81a3ad35742a004606a6ae84d5d1280111931a983e19ab9c07e07d07b07a135573ca00226ea8004d5d09aba2500223263530783357380f40f20ee0ec26aae7940044dd50009aba1500433502575c6ae85400ccd4094cd540c5d710009aba15002302b357426ae8940088c98d4c1d0cd5ce03b03a83983909aba25001135744a00226ae8940044d5d1280089aba25001135744a00226ae8940044d5d1280089aab9e5001137540026ae854008c8c8c8cccd5cd19b875001480188c070c098d5d09aab9e500323333573466e1d400920042301b3028357426aae7940108cccd5cd19b875003480088c06cc090d5d09aab9e500523333573466e1d401120002301e375c6ae84d55cf280311931a983799ab9c07107006e06d06c06b06a135573aa00226ea8004d5d09aba2500223263530683357380d40d20ce0cc20d0264c6a60ce66ae7124010350543500068066135573ca00226ea80044d55cea80209aba150021357426ae8940044d55cf280089baa001333333222222223232323232323235302c3530160082200222222222223233335305501425335308201533530820133353061120012235355040002223535504200322533530880133078004002133077003001108901335063335503f305e001337020fc90012832299a9a83418078011080089931a983c19ab9c49010b756e726561636861626c65000790771084011335738921124e4654206d757374206265206275726e6564000830115335308201533530820133037501135307b00122200110840113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e000830115335308201333553055120013505b50732533530830153353083013306635303d00122200333068307001b506a1084011085011333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011f556e6465726c79696e67204e4654206d75737420626520756e6c6f636b656400083011083011083012323232323225335308801533530880133301300735308101007222002001108a0113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e740008901153353088015335308801333573466e1cd4c2040401c88800821004228042240442280454cd4c22004cc015400ccc1b4c1d407541bc54cd4c22004cc0154008cc1b4c1d807d41bc4ccd54c16c48004d418541e4cc018cc1b4c1d8d4c2040401c88800541bccdc099b815004308501500230850150035016108901108901108a01133573892113526f79616c6974696573206e6f742070616964000890110890113370666e09400807120a09c0113370666e09400406520a09c01135307d003222002225335308501333573466e2000820c0421c0421804421c044ccd54c16048004d417941d8cc00c004009404c888d4c0fc0048894cd4c22004cc1ac01800c54cd4c22004ccd5cd19b8700533303c00206506508a0108901153353506e53353506e0012132353040001222222222253353507a333553067120015066235355051001225335309701333573466e3c00803c26404260044d41fc00c541f800884d41f4d4d5414400488004541ed4060541bc84c8ccd5cd19baf00200108c0108b013235355046001223374a900019aba0375200466ae80dd48009bb1081013355046501a3065008108901108901108901225335308301533530830133300e00200135307c00222200110850113357389213e45786163746c79206f6e65206e657720746f6b656e206d757374206265206d696e74656420616e642065786163746c79206f6e65206f6c64206275726e7400084011533530830133038501235307c00222200110850113357389211f4f776e6572206d757374207369676e20746865207472616e73616374696f6e0008401108401253353082015335308201533535062533535068301200221001132635307833573892010b756e726561636861626c6500079077108301221353550400022253353506600315335308601333573466e3c008c1880142200421c044ccd5cd19b87001480082200421c04421c04884224044210044cd5ce2491e45786163746c79206f6e65204e4654206d757374206265206d696e746564000830115335308201333553055120013505b5073253353083013306635303d00122200333068307001b506a1333573466e1cccc0dcd4c0f4004888008070d4c1f000888800d2002085010840110840135303850112222222222009108401133573892011d556e6465726c79696e67204e4654206d757374206265206c6f636b65640008301108301353036500f222222222200723222325335350605335350603006353030500922222222220072135063001150612153353505b001107c221353550390022253353505f0031080012213535503d0022253353506300315335308301533530830133073006500d133073002500a10840115335308301333573466e1c015200108501084011333573466e1c0052002085010840110840115335308301533530830133073002500d133073006500a10840115335308301333573466e1c005200108501084011333573466e1c0152002085010840110840110840122108601107b130553530720042223330760030050041305200132001355077225335350560011505d22135355034002225335307a3306a002500b1350620011300600332001355076225335350550011505c22135355033002225335307933069002500a1350610011300600313530285001222222222200913530110032200232001355073225335350520011505922135355030002225335307633066002500713505e00113006003135300f001223333530130012326353068335738921024c6800069067200123263530683357389201024c680006906723263530683357389201024c6800069067375c00c6eb8014dd700218310019bae00230620012212330010030022001212222300400521222230030052122223002005212222300100520011232230023758002640026aa0ba446666aae7c004940fc8cd40f8c010d5d080118019aba200205323232323333573466e1cd55cea801a400046660306464646666ae68cdc39aab9d5002480008cc118c04cd5d0a80119a8060091aba135744a004464c6a60ae66ae701641601581544d55cf280089baa00135742a006666aa00eeb94018d5d0a80119a8043ae357426ae8940088c98d4c14ccd5ce02a82a02902889aba25001135573ca00226ea80044cd54005d73ad112232230023756002640026aa0b644646666aae7c008940f88cd40f4cd54064c018d55cea80118029aab9e50023004357440060a426ae84004488c8c8cccd5cd19b875001480008d4108c014d5d09aab9e500323333573466e1d400920022504223263530513357380a60a40a009e09c26aae7540044dd5000919191999ab9a3370e6aae7540092000233017300535742a0046eb4d5d09aba25002232635304e3357380a009e09a09826aae7940044dd50009191999ab9a3370e6aae75400520002375c6ae84d55cf280111931a982619ab9c04e04d04b04a1375400224464646666ae68cdc3a800a40084a03c46666ae68cdc3a8012400446a042600c6ae84d55cf280211999ab9a3370ea00690001281091931a982799ab9c05105004e04d04c04b135573aa00226ea80048c8cccd5cd19b8750014800881588cccd5cd19b8750024800081588c98d4c12ccd5ce02682602502482409aab9d3754002464646464646666ae68cdc3a800a4018404846666ae68cdc3a80124014404c46666ae68cdc3a801a40104660486eb8d5d0a8029bad357426ae8940148cccd5cd19b875004480188cc098dd71aba15007375c6ae84d5d1280391999ab9a3370ea00a900211981598061aba15009375c6ae84d5d1280491999ab9a3370ea00c90011181698069aba135573ca01646666ae68cdc3a803a400046058601c6ae84d55cf280611931a982999ab9c05505405205105004f04e04d04c04b135573aa00826aae79400c4d55cf280109aab9e5001137540024646464646666ae68cdc3a800a4004466607e6eb4d5d0a8021bad35742a0066eb4d5d09aba2500323333573466e1d40092000230413008357426aae7940188c98d4c130cd5ce02702682582502489aab9d5003135744a00226aae7940044dd5000919191999ab9a3370ea00290011181f9bae357426aae79400c8cccd5cd19b875002480008c104dd71aba135573ca008464c6a609266ae7012c12812011c1184d55cea80089baa0011122232323333573466e1cd55cea80124000466aa020600c6ae854008c014d5d09aba25002232635304933573809609409008e26aae7940044dd500091119191800802990009aa8299119a9a819000a4000446a6aa02000444a66a60ac666ae68cdc780100482c02b8980380089803001990009aa8291119a9a818800a4000446a6aa01e00444a66a60aa666ae68cdc780100382b82b080089803001911a98018011111111111299a9a81e999aa981509000a8149299a982c199ab9a3371e0180020b40b226a0800022a07e006420b420b0444444444424666666666600201601401201000e00c00a008006004400244246600200600440024442466600200800600440022244246600200600422400244246600200600440022442466002006004240022442466002006004240022442466002006004240022424446006008224440042244400224002424444444600e01044244444446600c012010424444444600a01024444444008244444440064424444444660040120104424444444660020120104002266a01244a66a6a02c004420062002a02a640026aa0604422444a66a6a02400226a6a01800644002442666a6a01c00a440046008004666aa600e2400200a008002424444600800a44244446600600c00a44244446600400c00a424444600200a40022466a00644666a6a038006440040040026a6a0340024400224424660020060042400246e50ccd54c00c48005c5001199119801191b94330270010053530200032220023300237286a6040006444002660046e50d4c08000c88800c0054019401d22010032001355025221122253353500700110022213300500233355300712001005004001320013550242212225335350060021533535006001102822102922153353500800310292215335302a3300700400213335300912001007003001102b1122002122122330010040031200122353003002223530050032232335301000523353011004253353026333573466e3c0080040a009c5400c409c809c8cd4c044010809c94cd4c098ccd5cd19b8f00200102802715003102715335350090032153353500a00221335300e0022335300f0022335301300223353014002233019002001202a23353014002202a23301900200122202a2223353011004202a2225335302b333573466e1c01800c0b40b054cd4c0acccd5cd19b8700500202d02c13301a004001102c102c1025153353500900121025102522123300100300220011212230020031122001120012122300200322212233300100500400320012122300200321223001003200122333573466e1c00800405405088ccd5cd19b8f002001014013133500222533530110021013100101012212330010030021200123232323333573466e1cd55cea801a400046660166eb8d5d0a80198061aba15002375c6ae84d5d1280111931a980399ab9c009008006005135744a00226aae7940044dd5000a4c2400240029201035054310022212333001004003002200123253353007333573466e21400400c02402058540044dd6800a40004a66a6008666ae68cdc40008010030028a400020029040497a00990009aa802111299a9802199ab9a33710004904002003002899b8b0020011330033370600490400219b8b3370c0049040020008910010910009000889191800800911980198010010009" }, }; From 6da45e19a5819a12a33ebff37d7252409c0a5396 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 19 Aug 2022 11:45:57 -0600 Subject: [PATCH 14/27] Update tests to account for case of buyer not paying full price --- spago.dhall | 1 + test/Contract/Buy.purs | 153 ++++++++++++++++++++++++-------------- test/Contract/Util.purs | 159 ++++++++++++++++++++++++++++++---------- 3 files changed, 221 insertions(+), 92 deletions(-) diff --git a/spago.dhall b/spago.dhall index 326bced..c1a203f 100644 --- a/spago.dhall +++ b/spago.dhall @@ -34,6 +34,7 @@ You can edit this file as you like. , "partial" , "prelude" , "random" + , "record" , "spec" , "strings" , "text-encoding" diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index bcb6105..104d71a 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -12,26 +12,34 @@ import Contract.Address import Contract.Monad (Contract, liftContractM, liftedM) import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) -import Contract.Transaction (awaitTxConfirmed) +import Contract.Transaction + ( Transaction(..) + , TransactionHash + , TransactionOutput(..) + , TxBody(..) + , awaitTxConfirmed + , getTxByHash + ) +import Contract.Value (CurrencySymbol, TokenName, getLovelace) import Data.BigInt (BigInt) import Data.BigInt as BigInt -import Mote (group, only, skip, test) +import Mote (group, only, test) +import Plutus.Conversion (toPlutusCoin) +import Record (merge) import Seabug.Contract.Buy (marketplaceBuy') -import Seabug.Contract.Util - ( ReturnBehaviour(..) - , SeabugTxData - , minAdaOnlyUTxOValue - ) +import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData) import Seabug.MarketPlace (marketplaceValidatorAddr) -import Seabug.Types (MintParams) +import Seabug.Types (MintParams(..)) import Test.Contract.Util - ( ContractWrapAssertion + ( class WrappingAssertion + , ContractWrapAssertion , assertContract , assertLovelaceDecAtAddr - , assertLovelaceIncAtAddr + , assertLovelaceIncAtAddr' , callMintCnft , callMintSgNft , checkNftAtAddress + , findUtxoWithNft , mintParams1 , mintParams2 , mintParams3 @@ -39,22 +47,28 @@ import Test.Contract.Util , plutipConfig , privateStakeKey1 , privateStakeKey2 + , valueToLovelace , withAssertions + , wrapAndAssert ) import TestM (TestPlanM) -type BuyTestData = +type BuyTestData = BuyTestData' () + +type BuyTestData' r = { sellerPayAddr :: Address -- The enterprise address of the seller , buyerAddr :: Address -- The address used by the buyer , authorPayAddr :: Address -- The enterprise address of the author , mpScriptAddr :: Address -- The address of the marketplace script , mintParams :: MintParams -- The params used to mint the bought nft + , sgNft :: CurrencySymbol /\ TokenName -- The nft being bought + | r } -type PostBuyTestData = - { buyTestData :: BuyTestData - , txData :: SeabugTxData -- The data of the buy transaction - } +type PostBuyTestData = BuyTestData' + ( txData :: SeabugTxData -- The data of the buy transaction + , txHash :: TransactionHash -- The hash of the buy transaction + ) type ExpectedShares = { minMpGain :: BigInt @@ -62,14 +76,14 @@ type ExpectedShares = , minAuthorGain :: BigInt } -type BuyTestConfig = +type BuyTestConfig assertions = { mintParams :: MintParams , expectedShares :: ExpectedShares , retBehaviour :: ReturnBehaviour - , postBuyAssertions :: PostBuyTestData -> Array (Contract () Unit) + , assertions :: assertions } -buyTestConfig1 :: BuyTestConfig +buyTestConfig1 :: BuyTestConfig _ buyTestConfig1 = { mintParams: mintParams1 , expectedShares: @@ -78,10 +92,10 @@ buyTestConfig1 = , minAuthorGain: BigInt.fromInt $ 90 * 1000000 } , retBehaviour: ToMarketPlace - , postBuyAssertions: nftToMarketPlaceAssert + , assertions: nftToMarketPlaceAssert } -buyTestConfig2 :: BuyTestConfig +buyTestConfig2 :: BuyTestConfig _ buyTestConfig2 = { mintParams: mintParams2 , expectedShares: @@ -90,10 +104,10 @@ buyTestConfig2 = , minAuthorGain: BigInt.fromInt $ 100 * 1000000 } , retBehaviour: ToMarketPlace - , postBuyAssertions: nftToMarketPlaceAssert + , assertions: nftToMarketPlaceAssert } -buyTestConfig3 :: BuyTestConfig +buyTestConfig3 :: BuyTestConfig _ buyTestConfig3 = { mintParams: mintParams3 , expectedShares: @@ -102,10 +116,10 @@ buyTestConfig3 = , minAuthorGain: BigInt.fromInt $ 90 * 1000000 } , retBehaviour: ToMarketPlace - , postBuyAssertions: nftToMarketPlaceAssert + , assertions: nftToMarketPlaceAssert } -buyTestConfig4 :: BuyTestConfig +buyTestConfig4 :: BuyTestConfig _ buyTestConfig4 = buyTestConfig2 { mintParams = mintParams4 } suite :: TestPlanM Unit @@ -116,36 +130,53 @@ suite = test "Seller is author, no low prices, nft to buyer" $ mkBuyTest buyTestConfig1 { retBehaviour = ToCaller - , postBuyAssertions = nftToBuyerAssert + , assertions = nftToBuyerAssert } test "Seller is author, low marketplace share, nft to marketplace" $ mkBuyTest buyTestConfig2 test "Seller is author, low marketplace share, nft to buyer" $ mkBuyTest buyTestConfig2 { retBehaviour = ToCaller - , postBuyAssertions = nftToBuyerAssert + , assertions = nftToBuyerAssert } test "Seller is author, low author share, nft to marketplace" $ mkBuyTest buyTestConfig3 + only $ test "Seller is author, low author share, nft to buyer" $ + mkBuyTest buyTestConfig3 + { retBehaviour = ToCaller + , assertions = nftToBuyerAssert + } test "Seller is author, low author and marketplace shares, nft to marketplace" $ mkBuyTest buyTestConfig4 + only + $ test + "Seller is author, low author and marketplace shares, nft to buyer" + $ + mkBuyTest buyTestConfig4 + { retBehaviour = ToCaller + , assertions = nftToBuyerAssert + } nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) -nftToMarketPlaceAssert o@{ buyTestData: { mpScriptAddr } } = +nftToMarketPlaceAssert o@{ mpScriptAddr } = [ assertAddrHasNewAsset mpScriptAddr o , assertAddrLacksOldAsset mpScriptAddr o ] nftToBuyerAssert :: PostBuyTestData -> Array (Contract () Unit) -nftToBuyerAssert o@{ buyTestData: { buyerAddr, mpScriptAddr } } = +nftToBuyerAssert o@{ buyerAddr, mpScriptAddr } = [ assertAddrHasNewAsset buyerAddr o, assertAddrLacksOldAsset mpScriptAddr o ] -mkBuyTest :: BuyTestConfig -> Aff Unit -mkBuyTest { mintParams, expectedShares, retBehaviour, postBuyAssertions } = - runBuyTest mintParams retBehaviour (mkShareAssertions expectedShares) - postBuyAssertions +mkBuyTest + :: forall f + . WrappingAssertion f () PostBuyTestData + => BuyTestConfig f + -> Aff Unit +mkBuyTest { mintParams, expectedShares, retBehaviour, assertions } = + runBuyTest mintParams retBehaviour + (\b -> mkShareAssertions expectedShares b /\ assertions) assertAddrHasNewAsset :: Address -> PostBuyTestData -> Contract () Unit assertAddrHasNewAsset addr { txData } = @@ -159,30 +190,47 @@ assertAddrLacksOldAsset addr { txData } = <$> checkNftAtAddress txData.oldAsset addr mkShareAssertions - :: forall (r :: Row Type) - . ExpectedShares + :: ExpectedShares -> BuyTestData - -> Array (ContractWrapAssertion r) + -> Array (ContractWrapAssertion () PostBuyTestData) mkShareAssertions - { minMpGain, minSellerGain, minAuthorGain } - { sellerPayAddr, buyerAddr, authorPayAddr, mpScriptAddr, mintParams } = + e@{ minSellerGain, minAuthorGain } + b@{ sellerPayAddr, authorPayAddr } = + [ assertLovelaceIncAtAddr' "Author" authorPayAddr minAuthorGain + , assertLovelaceIncAtAddr' "Seller" sellerPayAddr minSellerGain + , buyerMarketplaceShareAssert e b + ] + +buyerMarketplaceShareAssert + :: ExpectedShares -> BuyTestData -> ContractWrapAssertion () PostBuyTestData +buyerMarketplaceShareAssert + { minMpGain } + { buyerAddr, mpScriptAddr, mintParams: MintParams mintParams, sgNft } + contract = do + (TransactionOutput mpNftUtxo) <- liftedM "Could not find sgNft utxo" + $ findUtxoWithNft sgNft mpScriptAddr let - minBuyerLoss = Nat.toBigInt (unwrap mintParams).price - in - [ assertLovelaceIncAtAddr "Author" authorPayAddr minAuthorGain - , assertLovelaceIncAtAddr "Seller" sellerPayAddr minSellerGain - , assertLovelaceDecAtAddr "Buyer" buyerAddr minBuyerLoss - , assertLovelaceIncAtAddr "Marketplace" mpScriptAddr minMpGain + mpInit = valueToLovelace mpNftUtxo.amount + + getBuyerExpectedLoss :: PostBuyTestData -> Contract () BigInt + getBuyerExpectedLoss { txHash } = do + (Transaction { body: TxBody { fee } }) <- + liftedM "Could not fetch buy transaction" $ getTxByHash txHash + let mpRemainder = mpInit - getLovelace (toPlutusCoin fee) + pure $ (Nat.toBigInt mintParams.price) - mpRemainder + contract `wrapAndAssert` + [ assertLovelaceIncAtAddr' "Marketplace" mpScriptAddr (minMpGain - mpInit) + , assertLovelaceDecAtAddr "Buyer" buyerAddr getBuyerExpectedLoss ] runBuyTest - :: forall (r :: Row Type) - . MintParams + :: forall (f :: Type) + . WrappingAssertion f () PostBuyTestData + => MintParams -> ReturnBehaviour - -> (BuyTestData -> Array (ContractWrapAssertion ())) - -> (PostBuyTestData -> Array (Contract () Unit)) + -> (BuyTestData -> f) -> Aff Unit -runBuyTest mintParams retBehaviour getAssertions getAfterAssertions = do +runBuyTest mintParams retBehaviour getAssertions = do let distribution = ( withStakeKey privateStakeKey1 @@ -201,7 +249,7 @@ runBuyTest mintParams retBehaviour getAssertions getAfterAssertions = do sellerPkh <- liftedM "Cannot get seller pkh" ownPaymentPubKeyHash liftContractM "Could not get seller payment address" $ payPubKeyHashEnterpriseAddress networkId sellerPkh - _ /\ nftData <- withKeyWallet seller do + sgNft /\ nftData <- withKeyWallet seller do cnft <- callMintCnft callMintSgNft cnft mintParams withKeyWallet buyer do @@ -214,10 +262,9 @@ runBuyTest mintParams retBehaviour getAssertions getAfterAssertions = do , buyerAddr , mpScriptAddr , mintParams + , sgNft: sgNft } - withAssertions (getAssertions buyTestData) do + void $ withAssertions (getAssertions buyTestData) do txHash /\ txData <- marketplaceBuy' retBehaviour nftData awaitTxConfirmed txHash - sequence_ (getAfterAssertions { buyTestData, txData }) - - pure unit + pure $ merge buyTestData { txData, txHash } diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index fdf27d3..e5b809f 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -1,13 +1,18 @@ module Test.Contract.Util - ( ContractWrapAssertion + ( BasicAssertion + , BasicAssertionMaker + , ContractWrapAssertion , assertContract , assertLovelaceChangeAtAddr , assertLovelaceDecAtAddr + , assertLovelaceDecAtAddr' , assertLovelaceIncAtAddr + , assertLovelaceIncAtAddr' , callMintCnft , callMintSgNft , checkBalanceChangeAtAddr , checkNftAtAddress + , class WrappingAssertion , findUtxoWithNft , mintParams1 , mintParams2 @@ -20,6 +25,7 @@ module Test.Contract.Util , valueAtAddress , valueToLovelace , withAssertions + , wrapAndAssert ) where import Contract.Prelude @@ -183,9 +189,12 @@ findUtxoWithNft (nftCs /\ nftTn) addr = do valueToLovelace :: Value -> BigInt valueToLovelace = getLovelace <<< valueToCoin -valueAtAddress :: forall (r :: Row Type). Address -> Contract r (Maybe Value) -valueAtAddress address = utxosAt address <#> map - (fold <<< map _.amount <<< map unwrap <<< Map.values <<< unwrap) +-- | Get the total value at an address. Throws an exception if this +-- | fails. +valueAtAddress :: forall (r :: Row Type). String -> Address -> Contract r Value +valueAtAddress name address = + liftedM ("Could not get " <> name <> " address value") $ utxosAt address <#> + map (fold <<< map _.amount <<< map unwrap <<< Map.values <<< unwrap) -- | `checkBalanceChangeAtAddr addrName addr check contract` returns -- | the result of passing to `check` the total value at the address @@ -194,16 +203,14 @@ checkBalanceChangeAtAddr :: forall (r :: Row Type) (a :: Type) (b :: Type) . String -> Address - -> (Value -> Value -> Contract r b) + -> (a -> Value -> Value -> Contract r b) -> Contract r a -> Contract r b checkBalanceChangeAtAddr addrName addr check contract = do - valueBefore <- liftedM ("Could not get " <> addrName <> " value before") $ - valueAtAddress addr - void $ contract - valueAfter <- liftedM ("Could not get " <> addrName <> " value after") $ - valueAtAddress addr - check valueBefore valueAfter + valueBefore <- valueAtAddress addrName addr + res <- contract + valueAfter <- valueAtAddress addrName addr + check res valueBefore valueAfter -- | `assertLovelaceChangeAtAddr addrName addr expected comp contract` -- | requires the predicate `comp actual expected` to succeed, where @@ -213,53 +220,127 @@ assertLovelaceChangeAtAddr :: forall (r :: Row Type) (a :: Type) . String -> Address - -> BigInt + -> (a -> Contract r BigInt) -> (BigInt -> BigInt -> Boolean) -> Contract r a - -> Contract r Unit -assertLovelaceChangeAtAddr addrName addr expected comp contract = - flip (checkBalanceChangeAtAddr addrName addr) contract \valBefore valAfter -> - do - let actual = valueToLovelace valAfter - valueToLovelace valBefore - assertContract - ( "Unexpected lovelace change at addr " <> addrName - <> "\n expected=" - <> show expected - <> "\n actual=" - <> show actual - ) - $ comp actual expected + -> Contract r a +assertLovelaceChangeAtAddr addrName addr getExpected comp contract = + flip (checkBalanceChangeAtAddr addrName addr) contract + \res valBefore valAfter -> + do + let actual = valueToLovelace valAfter - valueToLovelace valBefore + expected <- getExpected res + assertContract + ( "Unexpected lovelace change at addr " <> addrName + <> "\n expected=\t" + <> show expected + <> "\n actual=\t" + <> show actual + ) + $ comp actual expected + pure res --- | Requires that at least the passed amount of lovelace was gained +-- | Requires that at least the computed amount of lovelace was gained -- | at the address by calling the contract. assertLovelaceIncAtAddr + :: forall (r :: Row Type) (a :: Type) + . String + -> Address + -> (a -> Contract r BigInt) + -> Contract r a + -> Contract r a +assertLovelaceIncAtAddr addrName addr getMinGain contract = + assertLovelaceChangeAtAddr addrName addr getMinGain (>=) contract + +-- | Requires that at least the passed amount of lovelace was gained +-- | at the address by calling the contract. +assertLovelaceIncAtAddr' :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt -> Contract r a - -> Contract r Unit -assertLovelaceIncAtAddr addrName addr minGain contract = - assertLovelaceChangeAtAddr addrName addr minGain (>=) contract + -> Contract r a +assertLovelaceIncAtAddr' addrName addr minGain contract = + assertLovelaceIncAtAddr addrName addr (const $ pure minGain) contract --- | Requires that at least the passed amount of lovelace was lost at +-- | Requires that at least the computed amount of lovelace was lost at -- | the address by calling the contract. assertLovelaceDecAtAddr + :: forall (r :: Row Type) (a :: Type) + . String + -> Address + -> (a -> Contract r BigInt) + -> Contract r a + -> Contract r a +assertLovelaceDecAtAddr addrName addr getMinLoss contract = + assertLovelaceChangeAtAddr addrName addr (map negate <<< getMinLoss) (<=) + contract + +-- | Requires that at least the passed amount of lovelace was lost at +-- | the address by calling the contract. +assertLovelaceDecAtAddr' :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt -> Contract r a - -> Contract r Unit -assertLovelaceDecAtAddr addrName addr minLoss contract = - assertLovelaceChangeAtAddr addrName addr (negate minLoss) (<=) contract + -> Contract r a +assertLovelaceDecAtAddr' addrName addr minLoss contract = + assertLovelaceDecAtAddr addrName addr (const (pure minLoss)) contract + +-- | An assertion that can control when the contract is run. The +-- | assertion inhabiting this type should not call the contract more +-- | than once, as other assertions need to be able to make this +-- | assumption to succesfully compose. +type ContractWrapAssertion r a = Contract r a -> Contract r a -type ContractWrapAssertion (r :: Row Type) = Contract r Unit -> Contract r Unit +-- | An assertion that only needs the result of the contract. +type BasicAssertion r a b = a -> Contract r b --- | Composes assertions to be run with a contract. +type BasicAssertionMaker r a b = a -> Array (Contract r b) + +-- | Class to unify different methods of making assertions about a +-- | contract under a single interface. Note that the typechecker may +-- | need some help when using this class; try providing type +-- | annotations for your assertions using the type aliases for the +-- | instances of this class. +class WrappingAssertion f r a where + -- | Wrap a contract in an assertion. The wrapped contract itself + -- | becomes a contract which can be wrapped, allowing for + -- | composition of assertions. + -- | + -- | No guarantees are made about the order in which assertions are + -- | made. Assertions with side effects should not be used. + wrapAndAssert :: Contract r a -> f -> Contract r a + +instance WrappingAssertion (ContractWrapAssertion r a) r a where + wrapAndAssert contract assertion = assertion contract +else instance WrappingAssertion (BasicAssertionMaker r a b) r a where + wrapAndAssert contract assertionMaker = contract >>= \r -> + sequence_ (assertionMaker r) *> pure r +else instance WrappingAssertion (BasicAssertion r a b) r a where + wrapAndAssert contract assertion = contract >>= \r -> assertion r *> pure r + +instance WrappingAssertion (Array (ContractWrapAssertion r a)) r a where + wrapAndAssert contract assertions = ala Endo foldMap assertions contract +else instance WrappingAssertion (Array (BasicAssertion r a b)) r a where + wrapAndAssert contract assertions = contract >>= \r -> + traverse_ (_ $ r) assertions *> pure r + +instance + ( WrappingAssertion f r a + , WrappingAssertion g r a + ) => + WrappingAssertion (f /\ g) r a where + wrapAndAssert contract (assert1 /\ assert2) = + wrapAndAssert (wrapAndAssert contract assert1) assert2 + +-- | `wrapAndAssert` flipped withAssertions - :: forall (r :: Row Type) (a :: Type) - . Array (ContractWrapAssertion r) + :: forall (r :: Row Type) (a :: Type) (assertions :: Type) + . WrappingAssertion assertions r a + => assertions + -> Contract r a -> Contract r a - -> Contract r Unit -withAssertions assertions contract = ala Endo foldMap assertions (void contract) +withAssertions = flip wrapAndAssert From 0c2ef45ce9e599d41eb5e8426abe24d492cee2ba Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 19 Aug 2022 15:27:26 -0600 Subject: [PATCH 15/27] Add more buy test variations --- test/Contract/Buy.purs | 171 +++++++++++++++++++++++++--------------- test/Contract/Util.purs | 21 ++++- 2 files changed, 124 insertions(+), 68 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 104d71a..aa5e564 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -2,14 +2,8 @@ module Test.Contract.Buy (suite) where import Contract.Prelude -import Contract.Address - ( Address - , getNetworkId - , getWalletAddress - , ownPaymentPubKeyHash - , payPubKeyHashEnterpriseAddress - ) -import Contract.Monad (Contract, liftContractM, liftedM) +import Contract.Address (Address, getWalletAddress) +import Contract.Monad (Contract, liftedM) import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) import Contract.Transaction @@ -21,13 +15,15 @@ import Contract.Transaction , getTxByHash ) import Contract.Value (CurrencySymbol, TokenName, getLovelace) +import Data.Array ((:)) +import Data.Array as Array import Data.BigInt (BigInt) import Data.BigInt as BigInt -import Mote (group, only, test) +import Mote (group, only, skip, test) import Plutus.Conversion (toPlutusCoin) import Record (merge) import Seabug.Contract.Buy (marketplaceBuy') -import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData) +import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData, modify) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (MintParams(..)) import Test.Contract.Util @@ -47,7 +43,9 @@ import Test.Contract.Util , plutipConfig , privateStakeKey1 , privateStakeKey2 + , privateStakeKey3 , valueToLovelace + , walletEnterpriseAddress , withAssertions , wrapAndAssert ) @@ -80,7 +78,11 @@ type BuyTestConfig assertions = { mintParams :: MintParams , expectedShares :: ExpectedShares , retBehaviour :: ReturnBehaviour + , authorIsSeller :: Boolean , assertions :: assertions + , testName :: String + , skip :: Boolean + , only :: Boolean } buyTestConfig1 :: BuyTestConfig _ @@ -92,7 +94,11 @@ buyTestConfig1 = , minAuthorGain: BigInt.fromInt $ 90 * 1000000 } , retBehaviour: ToMarketPlace + , authorIsSeller: true , assertions: nftToMarketPlaceAssert + , testName: "no low shares" + , skip: false + , only: false } buyTestConfig2 :: BuyTestConfig _ @@ -104,7 +110,11 @@ buyTestConfig2 = , minAuthorGain: BigInt.fromInt $ 100 * 1000000 } , retBehaviour: ToMarketPlace + , authorIsSeller: true , assertions: nftToMarketPlaceAssert + , testName: "low marketplace share" + , skip: false + , only: false } buyTestConfig3 :: BuyTestConfig _ @@ -116,48 +126,63 @@ buyTestConfig3 = , minAuthorGain: BigInt.fromInt $ 90 * 1000000 } , retBehaviour: ToMarketPlace + , authorIsSeller: true , assertions: nftToMarketPlaceAssert + , testName: "low author share" + , skip: false + , only: false } buyTestConfig4 :: BuyTestConfig _ -buyTestConfig4 = buyTestConfig2 { mintParams = mintParams4 } +buyTestConfig4 = buyTestConfig2 + { mintParams = mintParams4, testName = "low author and marketplace shares" } -suite :: TestPlanM Unit -suite = - only $ group "Buy" do - test "Seller is author, no low prices, nft to marketplace" $ - mkBuyTest buyTestConfig1 - test "Seller is author, no low prices, nft to buyer" $ - mkBuyTest buyTestConfig1 - { retBehaviour = ToCaller - , assertions = nftToBuyerAssert - } - test "Seller is author, low marketplace share, nft to marketplace" $ - mkBuyTest buyTestConfig2 - test "Seller is author, low marketplace share, nft to buyer" $ - mkBuyTest buyTestConfig2 - { retBehaviour = ToCaller - , assertions = nftToBuyerAssert - } - test "Seller is author, low author share, nft to marketplace" $ - mkBuyTest buyTestConfig3 - only $ test "Seller is author, low author share, nft to buyer" $ - mkBuyTest buyTestConfig3 - { retBehaviour = ToCaller - , assertions = nftToBuyerAssert - } - test - "Seller is author, low author and marketplace shares, nft to marketplace" - $ - mkBuyTest buyTestConfig4 - only - $ test - "Seller is author, low author and marketplace shares, nft to buyer" - $ - mkBuyTest buyTestConfig4 +addNftToBuyerVariants :: Array (BuyTestConfig _) -> Array (BuyTestConfig _) +addNftToBuyerVariants = Array.uncons >>> case _ of + Nothing -> [] + Just { head: conf, tail: confs } -> + conf + : conf { retBehaviour = ToCaller , assertions = nftToBuyerAssert + , testName = conf.testName <> ", nft to buyer" } + : addNftToBuyerVariants confs + +authorNotSellerVariant + :: BuyTestConfig _ -> (ExpectedShares -> ExpectedShares) -> BuyTestConfig _ +authorNotSellerVariant conf updateShares = + conf + { expectedShares = updateShares conf.expectedShares + , authorIsSeller = false + , testName = conf.testName <> ", author is not seller" + } + +suite :: TestPlanM Unit +suite = + only $ group "Buy" do + let + tests = addNftToBuyerVariants + [ buyTestConfig1 + , authorNotSellerVariant buyTestConfig1 _ + { minSellerGain = BigInt.fromInt $ 80 * 1000000 + , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + } + , buyTestConfig2 + , authorNotSellerVariant buyTestConfig2 _ + { minSellerGain = BigInt.fromInt $ 90 * 1000000 + , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + } + , buyTestConfig3 + , authorNotSellerVariant buyTestConfig3 _ + { minSellerGain = BigInt.fromInt $ 90 * 1000000 + , minAuthorGain = BigInt.fromInt $ 0 + } + , buyTestConfig4 + , authorNotSellerVariant buyTestConfig4 _ + { minAuthorGain = BigInt.fromInt $ 0 } + ] + for_ tests mkBuyTest nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) nftToMarketPlaceAssert o@{ mpScriptAddr } = @@ -173,10 +198,13 @@ mkBuyTest :: forall f . WrappingAssertion f () PostBuyTestData => BuyTestConfig f - -> Aff Unit -mkBuyTest { mintParams, expectedShares, retBehaviour, assertions } = - runBuyTest mintParams retBehaviour - (\b -> mkShareAssertions expectedShares b /\ assertions) + -> TestPlanM Unit +mkBuyTest + conf@{ mintParams, expectedShares, retBehaviour, assertions, authorIsSeller } = + (if conf.skip then skip else if conf.only then only else identity) + $ test conf.testName + $ runBuyTest mintParams retBehaviour authorIsSeller + (\b -> mkShareAssertions expectedShares b /\ assertions) assertAddrHasNewAsset :: Address -> PostBuyTestData -> Contract () Unit assertAddrHasNewAsset addr { txData } = @@ -228,41 +256,54 @@ runBuyTest . WrappingAssertion f () PostBuyTestData => MintParams -> ReturnBehaviour + -> Boolean -> (BuyTestData -> f) -> Aff Unit -runBuyTest mintParams retBehaviour getAssertions = do +runBuyTest mintParams retBehaviour authorIsSeller getAssertions = do let distribution = ( withStakeKey privateStakeKey1 [ BigInt.fromInt 1_000_000_000 , BigInt.fromInt 2_000_000_000 ] - ) /\ - ( withStakeKey privateStakeKey2 - [ BigInt.fromInt 1_000_000_000 - , BigInt.fromInt 2_000_000_000 - ] - ) - runPlutipContract plutipConfig distribution \(seller /\ buyer) -> do - networkId <- getNetworkId - sellerPayAddr <- withKeyWallet seller do - sellerPkh <- liftedM "Cannot get seller pkh" ownPaymentPubKeyHash - liftContractM "Could not get seller payment address" $ - payPubKeyHashEnterpriseAddress networkId sellerPkh - sgNft /\ nftData <- withKeyWallet seller do + ) + /\ + ( withStakeKey privateStakeKey2 + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) + /\ + ( withStakeKey privateStakeKey3 + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) + runPlutipContract plutipConfig distribution \(author /\ seller /\ buyer) -> do + authorPayAddr <- walletEnterpriseAddress "author" author + sellerPayAddr <- walletEnterpriseAddress "seller" seller + initialSgNft /\ initialNftData <- withKeyWallet author do cnft <- callMintCnft callMintSgNft cnft mintParams + sgNft /\ nftData <- + if authorIsSeller then pure $ initialSgNft /\ initialNftData + else withKeyWallet seller do + txHash /\ txData <- marketplaceBuy' ToMarketPlace initialNftData + awaitTxConfirmed txHash + pure $ txData.newAsset /\ modify (_ { nftId = txData.newNft }) + initialNftData withKeyWallet buyer do buyerAddr <- liftedM "Could not get buyer addr" getWalletAddress mpScriptAddr <- marketplaceValidatorAddr let buyTestData = - { authorPayAddr: sellerPayAddr - , sellerPayAddr + { authorPayAddr + , sellerPayAddr: + if authorIsSeller then authorPayAddr else sellerPayAddr , buyerAddr , mpScriptAddr , mintParams - , sgNft: sgNft + , sgNft } void $ withAssertions (getAssertions buyTestData) do txHash /\ txData <- marketplaceBuy' retBehaviour nftData diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index e5b809f..d06134c 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -24,15 +24,22 @@ module Test.Contract.Util , privateStakeKey3 , valueAtAddress , valueToLovelace + , walletEnterpriseAddress , withAssertions , wrapAndAssert ) where import Contract.Prelude -import Contract.Address (Address, Slot(..)) +import Contract.Address + ( Address + , Slot(..) + , getNetworkId + , ownPaymentPubKeyHash + , payPubKeyHashEnterpriseAddress + ) import Contract.Config (PrivateStakeKey) -import Contract.Monad (Contract, liftedM) +import Contract.Monad (Contract, liftContractM, liftedM) import Contract.Numeric.Natural as Nat import Contract.Test.Plutip (PlutipConfig) import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) @@ -45,7 +52,7 @@ import Contract.Value , valueOf , valueToCoin ) -import Contract.Wallet (privateKeyFromBytes) +import Contract.Wallet (KeyWallet, privateKeyFromBytes, withKeyWallet) import Data.BigInt (BigInt) import Data.BigInt as BigInt import Data.Map as Map @@ -344,3 +351,11 @@ withAssertions -> Contract r a -> Contract r a withAssertions = flip wrapAndAssert + +walletEnterpriseAddress + :: forall (r :: Row Type). String -> KeyWallet -> Contract r Address +walletEnterpriseAddress walletName wallet = withKeyWallet wallet do + networkId <- getNetworkId + pkh <- liftedM ("Cannot get " <> walletName <> " pkh") ownPaymentPubKeyHash + liftContractM ("Could not get " <> walletName <> " payment address") $ + payPubKeyHashEnterpriseAddress networkId pkh From 4584566642299a4c220261bedad0af7618653a68 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 19 Aug 2022 15:51:46 -0600 Subject: [PATCH 16/27] Add price too low test --- test/Contract/Buy.purs | 72 +++++++++++++++++++++-------------------- test/Contract/Util.purs | 4 +++ 2 files changed, 41 insertions(+), 35 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index aa5e564..c99e946 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -40,6 +40,7 @@ import Test.Contract.Util , mintParams2 , mintParams3 , mintParams4 + , mintParams5 , plutipConfig , privateStakeKey1 , privateStakeKey2 @@ -49,6 +50,7 @@ import Test.Contract.Util , withAssertions , wrapAndAssert ) +import Test.Spec.Assertions (expectError) import TestM (TestPlanM) type BuyTestData = BuyTestData' () @@ -83,6 +85,7 @@ type BuyTestConfig assertions = , testName :: String , skip :: Boolean , only :: Boolean + , shouldError :: Boolean } buyTestConfig1 :: BuyTestConfig _ @@ -99,44 +102,42 @@ buyTestConfig1 = , testName: "no low shares" , skip: false , only: false + , shouldError: false } buyTestConfig2 :: BuyTestConfig _ -buyTestConfig2 = - { mintParams: mintParams2 - , expectedShares: - { minMpGain: BigInt.fromInt 0 - , minSellerGain: BigInt.fromInt $ 100 * 1000000 - , minAuthorGain: BigInt.fromInt $ 100 * 1000000 +buyTestConfig2 = buyTestConfig1 + { mintParams = mintParams2 + , expectedShares + { minMpGain = BigInt.fromInt 0 + , minSellerGain = BigInt.fromInt $ 100 * 1000000 + , minAuthorGain = BigInt.fromInt $ 100 * 1000000 } - , retBehaviour: ToMarketPlace - , authorIsSeller: true - , assertions: nftToMarketPlaceAssert - , testName: "low marketplace share" - , skip: false - , only: false + , testName = "low marketplace share" } buyTestConfig3 :: BuyTestConfig _ -buyTestConfig3 = - { mintParams: mintParams3 - , expectedShares: - { minMpGain: BigInt.fromInt $ 10 * 1000000 - , minSellerGain: BigInt.fromInt $ 90 * 1000000 - , minAuthorGain: BigInt.fromInt $ 90 * 1000000 +buyTestConfig3 = buyTestConfig1 + { mintParams = mintParams3 + , expectedShares + { minMpGain = BigInt.fromInt $ 10 * 1000000 + , minSellerGain = BigInt.fromInt $ 90 * 1000000 + , minAuthorGain = BigInt.fromInt $ 90 * 1000000 } - , retBehaviour: ToMarketPlace - , authorIsSeller: true - , assertions: nftToMarketPlaceAssert - , testName: "low author share" - , skip: false - , only: false + , testName = "low author share" } buyTestConfig4 :: BuyTestConfig _ buyTestConfig4 = buyTestConfig2 { mintParams = mintParams4, testName = "low author and marketplace shares" } +buyTestConfig5 :: BuyTestConfig _ +buyTestConfig5 = buyTestConfig1 + { mintParams = mintParams5 + , testName = "price too low for min ada requirement" + , shouldError = true + } + addNftToBuyerVariants :: Array (BuyTestConfig _) -> Array (BuyTestConfig _) addNftToBuyerVariants = Array.uncons >>> case _ of Nothing -> [] @@ -162,7 +163,7 @@ suite :: TestPlanM Unit suite = only $ group "Buy" do let - tests = addNftToBuyerVariants + tests = [ buyTestConfig5 ] <> addNftToBuyerVariants [ buyTestConfig1 , authorNotSellerVariant buyTestConfig1 _ { minSellerGain = BigInt.fromInt $ 80 * 1000000 @@ -184,16 +185,6 @@ suite = ] for_ tests mkBuyTest -nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) -nftToMarketPlaceAssert o@{ mpScriptAddr } = - [ assertAddrHasNewAsset mpScriptAddr o - , assertAddrLacksOldAsset mpScriptAddr o - ] - -nftToBuyerAssert :: PostBuyTestData -> Array (Contract () Unit) -nftToBuyerAssert o@{ buyerAddr, mpScriptAddr } = - [ assertAddrHasNewAsset buyerAddr o, assertAddrLacksOldAsset mpScriptAddr o ] - mkBuyTest :: forall f . WrappingAssertion f () PostBuyTestData @@ -203,9 +194,20 @@ mkBuyTest conf@{ mintParams, expectedShares, retBehaviour, assertions, authorIsSeller } = (if conf.skip then skip else if conf.only then only else identity) $ test conf.testName + $ (if conf.shouldError then expectError else identity) $ runBuyTest mintParams retBehaviour authorIsSeller (\b -> mkShareAssertions expectedShares b /\ assertions) +nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) +nftToMarketPlaceAssert o@{ mpScriptAddr } = + [ assertAddrHasNewAsset mpScriptAddr o + , assertAddrLacksOldAsset mpScriptAddr o + ] + +nftToBuyerAssert :: PostBuyTestData -> Array (Contract () Unit) +nftToBuyerAssert o@{ buyerAddr, mpScriptAddr } = + [ assertAddrHasNewAsset buyerAddr o, assertAddrLacksOldAsset mpScriptAddr o ] + assertAddrHasNewAsset :: Address -> PostBuyTestData -> Contract () Unit assertAddrHasNewAsset addr { txData } = assertContract "Address did not contain new sgNft" diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index d06134c..c99cc02 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -18,6 +18,7 @@ module Test.Contract.Util , mintParams2 , mintParams3 , mintParams4 + , mintParams5 , plutipConfig , privateStakeKey1 , privateStakeKey2 @@ -89,6 +90,9 @@ mintParams4 = modify (_ { daoShare = Nat.fromInt' 10, authorShare = Nat.fromInt' 10 }) mintParams1 +mintParams5 :: MintParams +mintParams5 = modify (_ { price = Nat.fromInt' 2 }) mintParams1 + callMintCnft ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) callMintCnft = do From d4260eadd437509cf05ebfa027ff0a36b604c59e Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Fri, 19 Aug 2022 16:46:38 -0600 Subject: [PATCH 17/27] Update CTL rev --- flake.lock | 16 ++++++++-------- flake.nix | 4 ++-- package-lock.json | 2 +- packages.dhall | 4 ++-- spago-packages.nix | 12 ++++++------ 5 files changed, 19 insertions(+), 19 deletions(-) diff --git a/flake.lock b/flake.lock index 89c14be..a6ba6d1 100644 --- a/flake.lock +++ b/flake.lock @@ -566,17 +566,17 @@ "servant-purescript": "servant-purescript_2" }, "locked": { - "lastModified": 1660312241, - "narHash": "sha256-qBAU3TS8X1IFUvcmJaW66jGgaP2Kwu/5WS7VFwBSPmY=", + "lastModified": 1660663244, + "narHash": "sha256-y+RAgaJZ2gQct0EIE8/0040Z4IvA9HktmcfOAWVOyeY=", "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "d918af3e09a80e0c3325f0350a97e753d18495bb", + "rev": "058eeed77b472231e34e8c994be071f4196a0b2f", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "d918af3e09a80e0c3325f0350a97e753d18495bb", + "rev": "058eeed77b472231e34e8c994be071f4196a0b2f", "type": "github" } }, @@ -1490,17 +1490,17 @@ "wai-routes": "wai-routes" }, "locked": { - "lastModified": 1656650330, - "narHash": "sha256-Rl5xNP3LVtuOzXXSsdAWNB3EXGRPsFPMvBO0TDUvSJE=", + "lastModified": 1660637986, + "narHash": "sha256-0I+yfuva9pg6pPHeWNO73oPRxCjh8I4ER0Egxf8XKdk=", "owner": "mlabs-haskell", "repo": "ogmios", - "rev": "e406801eaeb32b28cd84357596ca1512bff27741", + "rev": "9c04524d45de2c417ddda9e7ab0d587a54954c57", "type": "github" }, "original": { "owner": "mlabs-haskell", "repo": "ogmios", - "rev": "e406801eaeb32b28cd84357596ca1512bff27741", + "rev": "9c04524d45de2c417ddda9e7ab0d587a54954c57", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 0f3e089..9d34d10 100644 --- a/flake.nix +++ b/flake.nix @@ -12,8 +12,8 @@ repo = "cardano-transaction-lib"; # should be same rev as in packages.dhall # To update, do `spago2nix generate` - # `calum/823-staking-keys-plutip` branch - rev = "d918af3e09a80e0c3325f0350a97e753d18495bb"; + # `calum/fix-slot-length-type` branch + rev = "058eeed77b472231e34e8c994be071f4196a0b2f"; }; nixpkgs.follows = "cardano-transaction-lib/nixpkgs"; }; diff --git a/package-lock.json b/package-lock.json index c1c6cd3..1f3da96 100644 --- a/package-lock.json +++ b/package-lock.json @@ -2400,7 +2400,7 @@ "isobject": { "version": "3.0.1", "resolved": "https://registry.npmjs.org/isobject/-/isobject-3.0.1.tgz", - "integrity": "sha1-TkMekrEalzFjaqH5yNHMvP2reN8=", + "integrity": "sha512-WhB9zCku7EGTj/HQQRz5aUQEUeoQZH2bWcltRErOpymJ4boYE6wL9Tbr23krRPSZ+C5zqNSrSw+Cc7sZZ4b7vg==", "dev": true }, "jest-worker": { diff --git a/packages.dhall b/packages.dhall index 6d023d0..e9b4d0b 100644 --- a/packages.dhall +++ b/packages.dhall @@ -149,7 +149,7 @@ let additions = , "untagged-union" ] , repo = "https://github.com/mlabs-haskell/purescript-aeson.git" - , version = "286862a975f4bafbef15540c365bbbb0480e0bf7" + , version = "8e9d42980e824450c18c397295573160d1ce8424" } , aeson-helpers = { dependencies = @@ -363,7 +363,7 @@ let additions = ] , repo = "https://github.com/Plutonomicon/cardano-transaction-lib.git" -- should be same rev as in flake.nix - , version = "d918af3e09a80e0c3325f0350a97e753d18495bb" + , version = "058eeed77b472231e34e8c994be071f4196a0b2f" } } in upstream // additions diff --git a/spago-packages.nix b/spago-packages.nix index a76f84f..cd9954a 100644 --- a/spago-packages.nix +++ b/spago-packages.nix @@ -7,11 +7,11 @@ let "aeson" = pkgs.stdenv.mkDerivation { name = "aeson"; - version = "286862a975f4bafbef15540c365bbbb0480e0bf7"; + version = "8e9d42980e824450c18c397295573160d1ce8424"; src = pkgs.fetchgit { url = "https://github.com/mlabs-haskell/purescript-aeson.git"; - rev = "286862a975f4bafbef15540c365bbbb0480e0bf7"; - sha256 = "1d5h9n9f2qk8hjzqmhjfzwf86x3y60g3cm13gyvm5aaqjraaksvg"; + rev = "8e9d42980e824450c18c397295573160d1ce8424"; + sha256 = "0cz6wvrld468sc1i98wv7zsqxsp99lhianb4pxmsqfcz353a6sc9"; }; phases = "installPhase"; installPhase = "ln -s $src $out"; @@ -211,11 +211,11 @@ let "cardano-transaction-lib" = pkgs.stdenv.mkDerivation { name = "cardano-transaction-lib"; - version = "d918af3e09a80e0c3325f0350a97e753d18495bb"; + version = "058eeed77b472231e34e8c994be071f4196a0b2f"; src = pkgs.fetchgit { url = "https://github.com/Plutonomicon/cardano-transaction-lib.git"; - rev = "d918af3e09a80e0c3325f0350a97e753d18495bb"; - sha256 = "0riya801gm9fb7wyzhlazmla0cgapajja9ppa82m4pxw6kfi8458"; + rev = "058eeed77b472231e34e8c994be071f4196a0b2f"; + sha256 = "1rn99rjh3kn7k4npkx60igh1k3fkyk7i6221nwf09njrla0l1r6b"; }; phases = "installPhase"; installPhase = "ln -s $src $out"; From ed8f1d73d6e6b2eccf7ad535275a878bf7b003ca Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Mon, 22 Aug 2022 14:10:02 -0600 Subject: [PATCH 18/27] Specify rounding behaviour for shares --- test/Contract/Buy.purs | 109 ++++++++++++++++++++++++++++++++-------- test/Contract/Util.purs | 15 ++++++ 2 files changed, 103 insertions(+), 21 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index c99e946..8fa19a2 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -41,6 +41,9 @@ import Test.Contract.Util , mintParams3 , mintParams4 , mintParams5 + , mintParams6 + , mintParams7 + , mintParams8 , plutipConfig , privateStakeKey1 , privateStakeKey2 @@ -62,6 +65,7 @@ type BuyTestData' r = , mpScriptAddr :: Address -- The address of the marketplace script , mintParams :: MintParams -- The params used to mint the bought nft , sgNft :: CurrencySymbol /\ TokenName -- The nft being bought + , nftToBuyer :: Boolean -- Whether the nft is being sent directly to the buyer | r } @@ -138,6 +142,37 @@ buyTestConfig5 = buyTestConfig1 , shouldError = true } +buyTestConfig6 :: BuyTestConfig _ +buyTestConfig6 = buyTestConfig1 + { mintParams = mintParams6 + , testName = "fractional shares (.5)" + , expectedShares + { minMpGain = BigInt.fromInt $ 5_000_000 + , minSellerGain = BigInt.fromInt $ 45_000_005 + , minAuthorGain = BigInt.fromInt $ 45_000_005 + } + } + +buyTestConfig7 :: BuyTestConfig _ +buyTestConfig7 = buyTestConfig6 + { mintParams = mintParams7 + , testName = "fractional shares (.1)" + , expectedShares + { minSellerGain = BigInt.fromInt $ 45_000_001 + , minAuthorGain = BigInt.fromInt $ 45_000_001 + } + } + +buyTestConfig8 :: BuyTestConfig _ +buyTestConfig8 = buyTestConfig6 + { mintParams = mintParams8 + , testName = "fractional shares (.9)" + , expectedShares + { minSellerGain = BigInt.fromInt $ 45_000_009 + , minAuthorGain = BigInt.fromInt $ 45_000_009 + } + } + addNftToBuyerVariants :: Array (BuyTestConfig _) -> Array (BuyTestConfig _) addNftToBuyerVariants = Array.uncons >>> case _ of Nothing -> [] @@ -163,26 +198,45 @@ suite :: TestPlanM Unit suite = only $ group "Buy" do let - tests = [ buyTestConfig5 ] <> addNftToBuyerVariants - [ buyTestConfig1 - , authorNotSellerVariant buyTestConfig1 _ - { minSellerGain = BigInt.fromInt $ 80 * 1000000 - , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + tests = + [ buyTestConfig5 + -- Specify rounding behaviour + , buyTestConfig6 + , authorNotSellerVariant buyTestConfig6 _ + { minSellerGain = BigInt.fromInt $ 40_000_005 + , minAuthorGain = BigInt.fromInt $ 5_000_000 } - , buyTestConfig2 - , authorNotSellerVariant buyTestConfig2 _ - { minSellerGain = BigInt.fromInt $ 90 * 1000000 - , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + , buyTestConfig7 + , authorNotSellerVariant buyTestConfig7 _ + { minSellerGain = BigInt.fromInt $ 40_000_001 + , minAuthorGain = BigInt.fromInt $ 5_000_000 } - , buyTestConfig3 - , authorNotSellerVariant buyTestConfig3 _ - { minSellerGain = BigInt.fromInt $ 90 * 1000000 - , minAuthorGain = BigInt.fromInt $ 0 + , buyTestConfig8 + , authorNotSellerVariant buyTestConfig8 _ + { minSellerGain = BigInt.fromInt $ 40_000_009 + , minAuthorGain = BigInt.fromInt $ 5_000_000 } - , buyTestConfig4 - , authorNotSellerVariant buyTestConfig4 _ - { minAuthorGain = BigInt.fromInt $ 0 } - ] + ] <> + addNftToBuyerVariants + [ buyTestConfig1 + , authorNotSellerVariant buyTestConfig1 _ + { minSellerGain = BigInt.fromInt $ 80 * 1000000 + , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + } + , buyTestConfig2 + , authorNotSellerVariant buyTestConfig2 _ + { minSellerGain = BigInt.fromInt $ 90 * 1000000 + , minAuthorGain = BigInt.fromInt $ 10 * 1000000 + } + , buyTestConfig3 + , authorNotSellerVariant buyTestConfig3 _ + { minSellerGain = BigInt.fromInt $ 90 * 1000000 + , minAuthorGain = BigInt.fromInt $ 0 + } + , buyTestConfig4 + , authorNotSellerVariant buyTestConfig4 _ + { minAuthorGain = BigInt.fromInt $ 0 } + ] for_ tests mkBuyTest mkBuyTest @@ -235,21 +289,31 @@ buyerMarketplaceShareAssert :: ExpectedShares -> BuyTestData -> ContractWrapAssertion () PostBuyTestData buyerMarketplaceShareAssert { minMpGain } - { buyerAddr, mpScriptAddr, mintParams: MintParams mintParams, sgNft } + { buyerAddr + , mpScriptAddr + , mintParams: MintParams mintParams + , sgNft + , nftToBuyer + } contract = do (TransactionOutput mpNftUtxo) <- liftedM "Could not find sgNft utxo" $ findUtxoWithNft sgNft mpScriptAddr let mpInit = valueToLovelace mpNftUtxo.amount + price = Nat.toBigInt mintParams.price getBuyerExpectedLoss :: PostBuyTestData -> Contract () BigInt getBuyerExpectedLoss { txHash } = do (Transaction { body: TxBody { fee } }) <- liftedM "Could not fetch buy transaction" $ getTxByHash txHash - let mpRemainder = mpInit - getLovelace (toPlutusCoin fee) - pure $ (Nat.toBigInt mintParams.price) - mpRemainder + let + feeLovelace = getLovelace (toPlutusCoin fee) + mpRemainder = mpInit - feeLovelace + pure $ if nftToBuyer then price - mpRemainder else price + feeLovelace + + mpExp = if nftToBuyer then (minMpGain - mpInit) else minMpGain contract `wrapAndAssert` - [ assertLovelaceIncAtAddr' "Marketplace" mpScriptAddr (minMpGain - mpInit) + [ assertLovelaceIncAtAddr' "Marketplace" mpScriptAddr mpExp , assertLovelaceDecAtAddr "Buyer" buyerAddr getBuyerExpectedLoss ] @@ -306,6 +370,9 @@ runBuyTest mintParams retBehaviour authorIsSeller getAssertions = do , mpScriptAddr , mintParams , sgNft + , nftToBuyer: case retBehaviour of + ToCaller -> true + _ -> false } void $ withAssertions (getAssertions buyTestData) do txHash /\ txData <- marketplaceBuy' retBehaviour nftData diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index c99cc02..c99df23 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -19,6 +19,9 @@ module Test.Contract.Util , mintParams3 , mintParams4 , mintParams5 + , mintParams6 + , mintParams7 + , mintParams8 , plutipConfig , privateStakeKey1 , privateStakeKey2 @@ -93,6 +96,18 @@ mintParams4 = modify mintParams5 :: MintParams mintParams5 = modify (_ { price = Nat.fromInt' 2 }) mintParams1 +-- | For testing rounding behaviour. The shares should be: +-- | +-- | 50_000_005 1000 / 10000 = 5_000_000.5 +mintParams6 :: MintParams +mintParams6 = modify (_ { price = Nat.fromInt' 50_000_005 }) mintParams1 + +mintParams7 :: MintParams +mintParams7 = modify (_ { price = Nat.fromInt' 50_000_001 }) mintParams1 + +mintParams8 :: MintParams +mintParams8 = modify (_ { price = Nat.fromInt' 50_000_009 }) mintParams1 + callMintCnft ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) callMintCnft = do From dfe32d19627e4f673dea65bca55965417ede23d2 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Mon, 22 Aug 2022 14:21:30 -0600 Subject: [PATCH 19/27] Require exact lovelace changes --- test/Contract/Buy.purs | 12 +++++------ test/Contract/Util.purs | 48 ++++++++++++++++++++--------------------- 2 files changed, 30 insertions(+), 30 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 8fa19a2..96a08c1 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -30,8 +30,8 @@ import Test.Contract.Util ( class WrappingAssertion , ContractWrapAssertion , assertContract - , assertLovelaceDecAtAddr - , assertLovelaceIncAtAddr' + , assertLossAtAddr + , assertGainAtAddr' , callMintCnft , callMintSgNft , checkNftAtAddress @@ -280,8 +280,8 @@ mkShareAssertions mkShareAssertions e@{ minSellerGain, minAuthorGain } b@{ sellerPayAddr, authorPayAddr } = - [ assertLovelaceIncAtAddr' "Author" authorPayAddr minAuthorGain - , assertLovelaceIncAtAddr' "Seller" sellerPayAddr minSellerGain + [ assertGainAtAddr' "Author" authorPayAddr minAuthorGain + , assertGainAtAddr' "Seller" sellerPayAddr minSellerGain , buyerMarketplaceShareAssert e b ] @@ -313,8 +313,8 @@ buyerMarketplaceShareAssert mpExp = if nftToBuyer then (minMpGain - mpInit) else minMpGain contract `wrapAndAssert` - [ assertLovelaceIncAtAddr' "Marketplace" mpScriptAddr mpExp - , assertLovelaceDecAtAddr "Buyer" buyerAddr getBuyerExpectedLoss + [ assertGainAtAddr' "Marketplace" mpScriptAddr mpExp + , assertLossAtAddr "Buyer" buyerAddr getBuyerExpectedLoss ] runBuyTest diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index c99df23..39ef08e 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -4,10 +4,10 @@ module Test.Contract.Util , ContractWrapAssertion , assertContract , assertLovelaceChangeAtAddr - , assertLovelaceDecAtAddr - , assertLovelaceDecAtAddr' - , assertLovelaceIncAtAddr - , assertLovelaceIncAtAddr' + , assertLossAtAddr + , assertLossAtAddr' + , assertGainAtAddr + , assertGainAtAddr' , callMintCnft , callMintSgNft , checkBalanceChangeAtAddr @@ -266,54 +266,54 @@ assertLovelaceChangeAtAddr addrName addr getExpected comp contract = $ comp actual expected pure res --- | Requires that at least the computed amount of lovelace was gained --- | at the address by calling the contract. -assertLovelaceIncAtAddr +-- | Requires that the computed amount of lovelace was gained at the +-- | address by calling the contract. +assertGainAtAddr :: forall (r :: Row Type) (a :: Type) . String -> Address -> (a -> Contract r BigInt) -> Contract r a -> Contract r a -assertLovelaceIncAtAddr addrName addr getMinGain contract = - assertLovelaceChangeAtAddr addrName addr getMinGain (>=) contract +assertGainAtAddr addrName addr getMinGain contract = + assertLovelaceChangeAtAddr addrName addr getMinGain (==) contract --- | Requires that at least the passed amount of lovelace was gained --- | at the address by calling the contract. -assertLovelaceIncAtAddr' +-- | Requires that the passed amount of lovelace was gained at the +-- | address by calling the contract. +assertGainAtAddr' :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt -> Contract r a -> Contract r a -assertLovelaceIncAtAddr' addrName addr minGain contract = - assertLovelaceIncAtAddr addrName addr (const $ pure minGain) contract +assertGainAtAddr' addrName addr minGain contract = + assertGainAtAddr addrName addr (const $ pure minGain) contract --- | Requires that at least the computed amount of lovelace was lost at --- | the address by calling the contract. -assertLovelaceDecAtAddr +-- | Requires that the computed amount of lovelace was lost at the +-- | address by calling the contract. +assertLossAtAddr :: forall (r :: Row Type) (a :: Type) . String -> Address -> (a -> Contract r BigInt) -> Contract r a -> Contract r a -assertLovelaceDecAtAddr addrName addr getMinLoss contract = - assertLovelaceChangeAtAddr addrName addr (map negate <<< getMinLoss) (<=) +assertLossAtAddr addrName addr getMinLoss contract = + assertLovelaceChangeAtAddr addrName addr (map negate <<< getMinLoss) (==) contract --- | Requires that at least the passed amount of lovelace was lost at --- | the address by calling the contract. -assertLovelaceDecAtAddr' +-- | Requires that the passed amount of lovelace was lost at the +-- | address by calling the contract. +assertLossAtAddr' :: forall (r :: Row Type) (a :: Type) . String -> Address -> BigInt -> Contract r a -> Contract r a -assertLovelaceDecAtAddr' addrName addr minLoss contract = - assertLovelaceDecAtAddr addrName addr (const (pure minLoss)) contract +assertLossAtAddr' addrName addr minLoss contract = + assertLossAtAddr addrName addr (const (pure minLoss)) contract -- | An assertion that can control when the contract is run. The -- | assertion inhabiting this type should not call the contract more From 9c3f7cc3960dbd558d30c92890f5c7a07a44b5ae Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Mon, 22 Aug 2022 14:36:04 -0600 Subject: [PATCH 20/27] Minor changes --- test/Contract/Buy.purs | 30 ++++++++++++++++++------------ test/Contract/Util.purs | 14 ++++++++------ 2 files changed, 26 insertions(+), 18 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 96a08c1..fee43e5 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -58,7 +58,7 @@ import TestM (TestPlanM) type BuyTestData = BuyTestData' () -type BuyTestData' r = +type BuyTestData' (r :: Row Type) = { sellerPayAddr :: Address -- The enterprise address of the seller , buyerAddr :: Address -- The address used by the buyer , authorPayAddr :: Address -- The enterprise address of the author @@ -80,7 +80,7 @@ type ExpectedShares = , minAuthorGain :: BigInt } -type BuyTestConfig assertions = +type BuyTestConfig (assertions :: Type) = { mintParams :: MintParams , expectedShares :: ExpectedShares , retBehaviour :: ReturnBehaviour @@ -92,7 +92,9 @@ type BuyTestConfig assertions = , shouldError :: Boolean } -buyTestConfig1 :: BuyTestConfig _ +type BasicBuyAssertGroup = PostBuyTestData -> Array (Contract () Unit) + +buyTestConfig1 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig1 = { mintParams: mintParams1 , expectedShares: @@ -109,7 +111,7 @@ buyTestConfig1 = , shouldError: false } -buyTestConfig2 :: BuyTestConfig _ +buyTestConfig2 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig2 = buyTestConfig1 { mintParams = mintParams2 , expectedShares @@ -120,7 +122,7 @@ buyTestConfig2 = buyTestConfig1 , testName = "low marketplace share" } -buyTestConfig3 :: BuyTestConfig _ +buyTestConfig3 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig3 = buyTestConfig1 { mintParams = mintParams3 , expectedShares @@ -131,18 +133,18 @@ buyTestConfig3 = buyTestConfig1 , testName = "low author share" } -buyTestConfig4 :: BuyTestConfig _ +buyTestConfig4 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig4 = buyTestConfig2 { mintParams = mintParams4, testName = "low author and marketplace shares" } -buyTestConfig5 :: BuyTestConfig _ +buyTestConfig5 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig5 = buyTestConfig1 { mintParams = mintParams5 , testName = "price too low for min ada requirement" , shouldError = true } -buyTestConfig6 :: BuyTestConfig _ +buyTestConfig6 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig6 = buyTestConfig1 { mintParams = mintParams6 , testName = "fractional shares (.5)" @@ -153,7 +155,7 @@ buyTestConfig6 = buyTestConfig1 } } -buyTestConfig7 :: BuyTestConfig _ +buyTestConfig7 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig7 = buyTestConfig6 { mintParams = mintParams7 , testName = "fractional shares (.1)" @@ -163,7 +165,7 @@ buyTestConfig7 = buyTestConfig6 } } -buyTestConfig8 :: BuyTestConfig _ +buyTestConfig8 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig8 = buyTestConfig6 { mintParams = mintParams8 , testName = "fractional shares (.9)" @@ -173,7 +175,9 @@ buyTestConfig8 = buyTestConfig6 } } -addNftToBuyerVariants :: Array (BuyTestConfig _) -> Array (BuyTestConfig _) +addNftToBuyerVariants + :: Array (BuyTestConfig BasicBuyAssertGroup) + -> Array (BuyTestConfig BasicBuyAssertGroup) addNftToBuyerVariants = Array.uncons >>> case _ of Nothing -> [] Just { head: conf, tail: confs } -> @@ -186,7 +190,9 @@ addNftToBuyerVariants = Array.uncons >>> case _ of : addNftToBuyerVariants confs authorNotSellerVariant - :: BuyTestConfig _ -> (ExpectedShares -> ExpectedShares) -> BuyTestConfig _ + :: BuyTestConfig BasicBuyAssertGroup + -> (ExpectedShares -> ExpectedShares) + -> BuyTestConfig BasicBuyAssertGroup authorNotSellerVariant conf updateShares = conf { expectedShares = updateShares conf.expectedShares diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 39ef08e..54179ab 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -250,8 +250,8 @@ assertLovelaceChangeAtAddr -> (BigInt -> BigInt -> Boolean) -> Contract r a -> Contract r a -assertLovelaceChangeAtAddr addrName addr getExpected comp contract = - flip (checkBalanceChangeAtAddr addrName addr) contract +assertLovelaceChangeAtAddr addrName addr getExpected comp = + checkBalanceChangeAtAddr addrName addr \res valBefore valAfter -> do let actual = valueToLovelace valAfter - valueToLovelace valBefore @@ -319,19 +319,21 @@ assertLossAtAddr' addrName addr minLoss contract = -- | assertion inhabiting this type should not call the contract more -- | than once, as other assertions need to be able to make this -- | assumption to succesfully compose. -type ContractWrapAssertion r a = Contract r a -> Contract r a +type ContractWrapAssertion (r :: Row Type) (a :: Type) = + Contract r a -> Contract r a -- | An assertion that only needs the result of the contract. -type BasicAssertion r a b = a -> Contract r b +type BasicAssertion (r :: Row Type) (a :: Type) (b :: Type) = a -> Contract r b -type BasicAssertionMaker r a b = a -> Array (Contract r b) +type BasicAssertionMaker (r :: Row Type) (a :: Type) (b :: Type) = + a -> Array (Contract r b) -- | Class to unify different methods of making assertions about a -- | contract under a single interface. Note that the typechecker may -- | need some help when using this class; try providing type -- | annotations for your assertions using the type aliases for the -- | instances of this class. -class WrappingAssertion f r a where +class WrappingAssertion (f :: Type) (r :: Row Type) (a :: Type) where -- | Wrap a contract in an assertion. The wrapped contract itself -- | becomes a contract which can be wrapped, allowing for -- | composition of assertions. From f2cf5322186844ae488bd30c353a87eda3854697 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Mon, 22 Aug 2022 18:03:24 -0600 Subject: [PATCH 21/27] Add tests for datums and metadata --- src/Seabug/Contract/Mint.purs | 8 +- src/Seabug/Contract/Util.purs | 23 +++-- test/Contract/Buy.purs | 26 +++++- test/Contract/Minting.purs | 71 ++++++++------- test/Contract/Util.purs | 160 ++++++++++++++++++++++++++++++---- 5 files changed, 224 insertions(+), 64 deletions(-) diff --git a/src/Seabug/Contract/Mint.purs b/src/Seabug/Contract/Mint.purs index 46b2e16..96d8d45 100644 --- a/src/Seabug/Contract/Mint.purs +++ b/src/Seabug/Contract/Mint.purs @@ -11,8 +11,9 @@ import Contract.Address , ownStakePubKeyHash , payPubKeyHashBaseAddress ) +import Contract.AuxiliaryData (setTxMetadata) import Contract.Chain (currentSlot, currentTime) -import Contract.Monad (Contract, liftContractM, liftedE, liftedM) +import Contract.Monad (Contract, liftContractE, liftContractM, liftedE, liftedM) import Contract.PlutusData (toData) import Contract.ScriptLookups as Lookups import Contract.Scripts (validatorHash) @@ -26,7 +27,7 @@ import Contract.Value , scriptCurrencySymbol , singleton ) -import Seabug.Contract.Util (setSeabugMetadata) +import Seabug.Contract.Util (getSeabugMetadata) import Seabug.Lock (mkLockScript) import Seabug.MarketPlace (marketplaceValidator) import Seabug.MintingPolicy as MintingPolicy @@ -107,7 +108,8 @@ mintWithCollection' ] unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints let nftData = NftData { nftId: nft, nftCollection: collection } - unbalancedTxWithMetadata <- setSeabugMetadata nftData curr unbalancedTx + metadata <- liftContractE $ getSeabugMetadata nftData curr + unbalancedTxWithMetadata <- setTxMetadata unbalancedTx metadata signedTx <- liftedE $ balanceAndSignTxE unbalancedTxWithMetadata transactionHash <- submit signedTx log $ "Mint transaction successfully submitted with hash: " diff --git a/src/Seabug/Contract/Util.purs b/src/Seabug/Contract/Util.purs index abd18d9..71b623f 100644 --- a/src/Seabug/Contract/Util.purs +++ b/src/Seabug/Contract/Util.purs @@ -5,14 +5,14 @@ module Seabug.Contract.Util , mkChangeNftIdTxData , modify , seabugTxToMarketTx - , setSeabugMetadata + , getSeabugMetadata ) where import Contract.Prelude import Contract.Address (getNetworkId) import Contract.AuxiliaryData (setTxMetadata) -import Contract.Monad (Contract, liftContractM, liftedE, liftedM) +import Contract.Monad (Contract, liftContractE, liftContractM, liftedE, liftedM) import Contract.Numeric.Natural (toBigInt) import Contract.PlutusData ( Datum(Datum) @@ -128,10 +128,10 @@ seabugTxToMarketTx name retBehaviour mkTxData nftData = do ToCaller -> mempty -- Balancing will return the token to the caller txDatumsRedeemerTxIns <- liftedE $ mkUnbalancedTx lookups constraints - txWithMetadata <- - setSeabugMetadata (modify (_ { nftId = txData.newNft }) nftData) - (fst txData.newAsset) - txDatumsRedeemerTxIns + metadata <- liftContractE $ getSeabugMetadata + (modify (_ { nftId = txData.newNft }) nftData) + (fst txData.newAsset) + txWithMetadata <- setTxMetadata txDatumsRedeemerTxIns metadata signedTx <- liftedE ( lmap @@ -216,22 +216,21 @@ minAdaOnlyUTxOValue :: BigInt minAdaOnlyUTxOValue = BigInt.fromInt 2_000_000 -- | Set metadata on the transaction for the given NFT -setSeabugMetadata +getSeabugMetadata :: forall (r :: Row Type) . NftData -> CurrencySymbol -- | The currency symbol of the self-governed nft - -> UnattachedUnbalancedTx - -> Contract r UnattachedUnbalancedTx -setSeabugMetadata (NftData nftData) sgNftCurr tx = do + -> Either String SeabugMetadata +getSeabugMetadata (NftData nftData) sgNftCurr = do let nftCollection = unwrap nftData.nftCollection nftId = unwrap nftData.nftId - natToShare nat = liftContractM "Invalid share" + natToShare nat = note "Invalid share" $ mkShare =<< BigInt.toInt (toBigInt nat) authorShareValidated <- natToShare nftCollection.authorShare marketplaceShareValidated <- natToShare nftCollection.daoShare - setTxMetadata tx $ SeabugMetadata + pure $ SeabugMetadata { policyId: sgNftCurr , mintPolicy: "V1" , collectionNftCS: nftCollection.collectionNftCs diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index fee43e5..8912040 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -5,6 +5,7 @@ import Contract.Prelude import Contract.Address (Address, getWalletAddress) import Contract.Monad (Contract, liftedM) import Contract.Numeric.Natural as Nat +import Contract.PlutusData (Datum(..), toData) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) import Contract.Transaction ( Transaction(..) @@ -30,11 +31,12 @@ import Test.Contract.Util ( class WrappingAssertion , ContractWrapAssertion , assertContract - , assertLossAtAddr , assertGainAtAddr' + , assertLossAtAddr , callMintCnft , callMintSgNft , checkNftAtAddress + , checkUtxoWithDatum , findUtxoWithNft , mintParams1 , mintParams2 @@ -256,7 +258,9 @@ mkBuyTest $ test conf.testName $ (if conf.shouldError then expectError else identity) $ runBuyTest mintParams retBehaviour authorIsSeller - (\b -> mkShareAssertions expectedShares b /\ assertions) + \b -> + -- TODO: check tx metadata + mkShareAssertions expectedShares b /\ mkDatumAssertions /\ assertions nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) nftToMarketPlaceAssert o@{ mpScriptAddr } = @@ -279,6 +283,22 @@ assertAddrLacksOldAsset addr { txData } = =<< not <$> checkNftAtAddress txData.oldAsset addr +mkDatumAssertions :: PostBuyTestData -> Array (Contract () Unit) +mkDatumAssertions + { sellerPayAddr, authorPayAddr, mpScriptAddr, txData: { oldAsset } } = + let + datum = Datum $ toData oldAsset + in + -- TODO: check that these utxos have the expected payment amounts + -- TODO: account for cases where shares were too low + [ assertContract "Seller did not have payment utxo with datum" =<< + checkUtxoWithDatum "seller" datum sellerPayAddr + , assertContract "Author did not have payment utxo with datum" =<< + checkUtxoWithDatum "author" datum authorPayAddr + , assertContract "Marketplace did not have payment utxo with datum" =<< + checkUtxoWithDatum "marketplace" datum mpScriptAddr + ] + mkShareAssertions :: ExpectedShares -> BuyTestData @@ -354,7 +374,7 @@ runBuyTest mintParams retBehaviour authorIsSeller getAssertions = do runPlutipContract plutipConfig distribution \(author /\ seller /\ buyer) -> do authorPayAddr <- walletEnterpriseAddress "author" author sellerPayAddr <- walletEnterpriseAddress "seller" seller - initialSgNft /\ initialNftData <- withKeyWallet author do + { sgNft: initialSgNft, nftData: initialNftData } <- withKeyWallet author do cnft <- callMintCnft callMintSgNft cnft mintParams sgNft /\ nftData <- diff --git a/test/Contract/Minting.purs b/test/Contract/Minting.purs index 86bfc68..b3c59c6 100644 --- a/test/Contract/Minting.purs +++ b/test/Contract/Minting.purs @@ -2,24 +2,22 @@ module Test.Contract.Minting (suite) where import Contract.Prelude -import Contract.Address - ( getNetworkId - , getWalletAddress - , validatorHashEnterpriseAddress - ) -import Contract.Monad (liftContractM, liftedM) -import Contract.PlutusData (fromData, getDatumByHash) +import Contract.Address (getWalletAddress, scriptHashAddress) +import Contract.Chain (currentSlot) +import Contract.Monad (liftContractE, liftedM) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) -import Contract.Transaction (TransactionOutput(..)) import Data.BigInt as BigInt -import Mote (test) +import Mote (only, test) +import Seabug.Contract.Util (getSeabugMetadata) import Seabug.MarketPlace (marketplaceValidatorAddr) -import Seabug.Types (MarketplaceDatum(..)) +import Seabug.Types (LockDatum(..), MarketplaceDatum(..)) import Test.Contract.Util ( assertContract + , assertTxHasMetadata , callMintCnft , callMintSgNft , checkNftAtAddress + , assertOutputHasDatum , findUtxoWithNft , mintParams1 , plutipConfig @@ -29,7 +27,7 @@ import TestM (TestPlanM) suite :: TestPlanM Unit suite = - test "Minting" do + only $ test "Minting" do let distribution = ( withStakeKey privateStakeKey1 @@ -44,29 +42,40 @@ suite = assertContract "Could not find cnft at user address" =<< checkNftAtAddress cnft aliceAddr - sgNft /\ nftData <- callMintSgNft cnft mintParams1 + expectedEntered <- currentSlot + { sgNft, nftData, txHash } <- callMintSgNft cnft mintParams1 scriptAddr <- marketplaceValidatorAddr - TransactionOutput sgNftUtxo <- + sgNftUtxo <- liftedM "Could not find sgNft at marketplace address" $ findUtxoWithNft sgNft scriptAddr - lockScriptAddr <- liftedM "Could not get locking script addr" - $ validatorHashEnterpriseAddress - <$> getNetworkId - <*> pure (unwrap nftData # _.nftCollection # unwrap # _.lockingScript) - assertContract "Could not find cnft at locking address" =<< - checkNftAtAddress cnft lockScriptAddr + let + nftColl = unwrap nftData # _.nftCollection # unwrap + lockScriptAddr = scriptHashAddress nftColl.lockingScript + cnftUtxo <- + liftedM "Could not find cnft at locking address" $ + findUtxoWithNft cnft lockScriptAddr + + assertOutputHasDatum "cnft" + ( LockDatum + { sgNft: fst sgNft + , entered: expectedEntered + , underlyingTn: snd cnft + } + ) + ( \(LockDatum exp) (LockDatum act) -> exp.sgNft == act.sgNft + && exp.underlyingTn + == act.underlyingTn + ) + cnftUtxo + assertOutputHasDatum "sgNft" + (MarketplaceDatum { getMarketplaceDatum: sgNft }) + (==) + sgNftUtxo + + expectedSeabugMetadata <- liftContractE $ + getSeabugMetadata nftData (fst sgNft) + assertTxHasMetadata "sgNft" txHash expectedSeabugMetadata - -- TODO: Don't test the datums directly, test it via - -- integration with the other contracts - sgNftDatumHash <- liftContractM "sgNft utxo does not have datum hash" - sgNftUtxo.dataHash - rawMpDatum <- liftedM "Could not get sgNft utxo's datum" $ - getDatumByHash sgNftDatumHash - MarketplaceDatum { getMarketplaceDatum: mpDatum } <- - liftContractM "Could not parse sgNft utxo's datum" - $ fromData - $ unwrap rawMpDatum - assertContract "Marketplace datum did not hold sgNft's info" - (mpDatum == sgNft) + pure unit diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 54179ab..2abc386 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -3,16 +3,22 @@ module Test.Contract.Util , BasicAssertionMaker , ContractWrapAssertion , assertContract - , assertLovelaceChangeAtAddr - , assertLossAtAddr - , assertLossAtAddr' , assertGainAtAddr , assertGainAtAddr' + , assertLossAtAddr + , assertLossAtAddr' + , assertLovelaceChangeAtAddr + , assertOutputHasDatum + , assertTxHasMetadata , callMintCnft , callMintSgNft , checkBalanceChangeAtAddr , checkNftAtAddress + , checkOutputHasDatum + , checkUtxoWithDatum , class WrappingAssertion + , findM + , findUtxoWithDatum , findUtxoWithNft , mintParams1 , mintParams2 @@ -45,8 +51,16 @@ import Contract.Address import Contract.Config (PrivateStakeKey) import Contract.Monad (Contract, liftContractM, liftedM) import Contract.Numeric.Natural as Nat +import Contract.PlutusData (class FromData, fromData, getDatumByHash) import Contract.Test.Plutip (PlutipConfig) -import Contract.Transaction (TransactionOutput(..), awaitTxConfirmed) +import Contract.Transaction + ( AuxiliaryData(..) + , Transaction(..) + , TransactionHash + , TransactionOutput(..) + , awaitTxConfirmed + , getTxByHash + ) import Contract.Utxos (utxosAt) import Contract.Value ( CurrencySymbol @@ -57,6 +71,7 @@ import Contract.Value , valueToCoin ) import Contract.Wallet (KeyWallet, privateKeyFromBytes, withKeyWallet) +import Control.Monad.Except (catchError) import Data.BigInt (BigInt) import Data.BigInt as BigInt import Data.Map as Map @@ -64,11 +79,14 @@ import Data.Monoid.Endo (Endo(..)) import Data.Newtype (ala) import Data.UInt as UInt import Effect.Exception (throw) +import Metadata.FromMetadata (class FromMetadata, fromMetadata) +import Metadata.MetadataType (class MetadataType, metadataLabel) import Partial.Unsafe (unsafePartial) import Seabug.Contract.CnftMint (mintCnft) import Seabug.Contract.Mint (mintWithCollection') import Seabug.Contract.Util (modify) import Seabug.Types (MintCnftParams(..), MintParams, NftData) +import Type.Proxy (Proxy(..)) import Types.BigNum as BigNum import Types.RawBytes (hexToRawBytes) @@ -130,15 +148,18 @@ callMintSgNft :: forall (r :: Row Type) . Tuple CurrencySymbol TokenName -> MintParams - -> Contract r ((CurrencySymbol /\ TokenName) /\ NftData) + -> Contract r + { sgNft :: (CurrencySymbol /\ TokenName) + , nftData :: NftData + , txHash :: TransactionHash + } callMintSgNft cnft mintParams = do log "Minting sgNft..." - sgNftTxHash /\ sgNft /\ nftData <- mintWithCollection' cnft mintParams - log $ "Waiting for confirmation of nft transaction: " <> show - sgNftTxHash - awaitTxConfirmed sgNftTxHash - log $ "Nft transaction confirmed: " <> show sgNftTxHash - pure $ sgNft /\ nftData + txHash /\ sgNft /\ nftData <- mintWithCollection' cnft mintParams + log $ "Waiting for confirmation of nft transaction: " <> show txHash + awaitTxConfirmed txHash + log $ "Nft transaction confirmed: " <> show txHash + pure { sgNft, nftData, txHash } plutipConfig :: PlutipConfig plutipConfig = @@ -258,10 +279,7 @@ assertLovelaceChangeAtAddr addrName addr getExpected comp = expected <- getExpected res assertContract ( "Unexpected lovelace change at addr " <> addrName - <> "\n expected=\t" - <> show expected - <> "\n actual=\t" - <> show actual + <> mkExpectedVsActual expected actual ) $ comp actual expected pure res @@ -380,3 +398,115 @@ walletEnterpriseAddress walletName wallet = withKeyWallet wallet do pkh <- liftedM ("Cannot get " <> walletName <> " pkh") ownPaymentPubKeyHash liftContractM ("Could not get " <> walletName <> " payment address") $ payPubKeyHashEnterpriseAddress networkId pkh + +assertOutputHasDatum + :: forall (a :: Type) (r :: Row Type) + . FromData a + => Show a + => String + -> a + -> (a -> a -> Boolean) + -> TransactionOutput + -> Contract r Unit +assertOutputHasDatum outputName expectedDatum comp (TransactionOutput output) = + do + datumHash <- liftContractM (outputName <> " utxo does not have datum hash") + output.dataHash + rawMpDatum <- liftedM ("Could not get " <> outputName <> " utxo's datum") $ + getDatumByHash datumHash + actualDatum <- + liftContractM ("Could not parse " <> outputName <> " utxo's datum") + $ fromData + $ unwrap rawMpDatum + assertContract + ( "Unexpected " <> outputName <> " datum value: " + <> mkExpectedVsActual expectedDatum actualDatum + ) + (comp expectedDatum actualDatum) + +checkOutputHasDatum + :: forall (a :: Type) (r :: Row Type) + . FromData a + => Show a + => String + -> a + -> (a -> a -> Boolean) + -> TransactionOutput + -> Contract r Boolean +checkOutputHasDatum outputName expectedDatum comp output = + (assertOutputHasDatum outputName expectedDatum comp output *> pure true) + `catchError` (const $ pure false) + +assertTxHasMetadata + :: forall (a :: Type) (r :: Row Type) + . MetadataType a + => FromMetadata a + => Eq a + => Show a + => String + -> TransactionHash + -> a + -> Contract r Unit +assertTxHasMetadata metadataName txHash expectedMetadata = do + Transaction { auxiliaryData } <- + liftedM ("Could not get " <> metadataName <> " tx") $ + getTxByHash txHash + generalMetadata <- + liftContractM ("Transaction did not hold metadata") + $ auxiliaryData + >>= case _ of AuxiliaryData a -> unwrap <$> a.metadata + rawMetadata <- + liftContractM ("Transaction did not hold " <> metadataName <> " metadata") $ + Map.lookup + (metadataLabel (Proxy :: Proxy a)) + generalMetadata + metadata <- + liftContractM ("Could not parse " <> metadataName <> " metadata") $ + fromMetadata rawMetadata + assertContract + ( "Unexpected " <> metadataName <> " metadata value: " + <> mkExpectedVsActual expectedMetadata metadata + ) + (metadata == expectedMetadata) + +checkUtxoWithDatum + :: forall (a :: Type) (r :: Row Type) + . FromData a + => Eq a + => Show a + => String + -> a + -> Address + -> Contract r Boolean +checkUtxoWithDatum utxoName datum addr = + isJust <$> findUtxoWithDatum utxoName datum addr + +findUtxoWithDatum + :: forall (a :: Type) (r :: Row Type) + . FromData a + => Eq a + => Show a + => String + -> a + -> Address + -> Contract r (Maybe TransactionOutput) +findUtxoWithDatum utxoName datum addr = do + utxos <- liftedM "Could not get utxos" $ map unwrap <$> utxosAt addr + findM (checkOutputHasDatum utxoName datum (==)) utxos + +findM + :: forall (a :: Type) (f :: Type -> Type) (m :: Type -> Type) + . Foldable f + => Monad m + => (a -> m Boolean) + -> f a + -> m (Maybe a) +findM pred = foldM h Nothing + where + h (Just x) _ = pure $ Just x + h Nothing x = pred x >>= pure <<< if _ then Just x else Nothing + +mkExpectedVsActual + :: forall (a :: Type) (b :: Type). Show a => Show b => a -> b -> String +mkExpectedVsActual expected actual = + "\nExpected:\n" <> show expected <> "\nbut got:\n" <> show actual From 81a19140ff1b613cdcba4498c2578ad51b7e9206 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Tue, 23 Aug 2022 13:03:06 -0600 Subject: [PATCH 22/27] Fix payment datums tests and check for correct payments We were already checking for total correct payment, but now we check for the specific payment utxos with the correct amounts and datum --- test/Contract/Buy.purs | 233 +++++++++++++++++++++------------------- test/Contract/Util.purs | 14 ++- test/Plutip.purs | 2 +- 3 files changed, 135 insertions(+), 114 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 8912040..0e70d02 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -24,7 +24,12 @@ import Mote (group, only, skip, test) import Plutus.Conversion (toPlutusCoin) import Record (merge) import Seabug.Contract.Buy (marketplaceBuy') -import Seabug.Contract.Util (ReturnBehaviour(..), SeabugTxData, modify) +import Seabug.Contract.Util + ( ReturnBehaviour(..) + , SeabugTxData + , minAdaOnlyUTxOValue + , modify + ) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (MintParams(..)) import Test.Contract.Util @@ -36,7 +41,8 @@ import Test.Contract.Util , callMintCnft , callMintSgNft , checkNftAtAddress - , checkUtxoWithDatum + , checkOutputHasDatum + , findUtxo , findUtxoWithNft , mintParams1 , mintParams2 @@ -77,9 +83,9 @@ type PostBuyTestData = BuyTestData' ) type ExpectedShares = - { minMpGain :: BigInt - , minSellerGain :: BigInt - , minAuthorGain :: BigInt + { mpGain :: BigInt + , sellerGain :: BigInt + , authorGain :: BigInt } type BuyTestConfig (assertions :: Type) = @@ -100,9 +106,9 @@ buyTestConfig1 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig1 = { mintParams: mintParams1 , expectedShares: - { minMpGain: BigInt.fromInt $ 10 * 1000000 - , minSellerGain: BigInt.fromInt $ 90 * 1000000 - , minAuthorGain: BigInt.fromInt $ 90 * 1000000 + { mpGain: BigInt.fromInt $ 10 * 1000000 + , sellerGain: BigInt.fromInt $ 80 * 1000000 + , authorGain: BigInt.fromInt $ 10 * 1000000 } , retBehaviour: ToMarketPlace , authorIsSeller: true @@ -117,9 +123,9 @@ buyTestConfig2 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig2 = buyTestConfig1 { mintParams = mintParams2 , expectedShares - { minMpGain = BigInt.fromInt 0 - , minSellerGain = BigInt.fromInt $ 100 * 1000000 - , minAuthorGain = BigInt.fromInt $ 100 * 1000000 + { mpGain = BigInt.fromInt 0 + , sellerGain = BigInt.fromInt $ 90 * 1000000 + , authorGain = BigInt.fromInt $ 10 * 1000000 } , testName = "low marketplace share" } @@ -128,16 +134,23 @@ buyTestConfig3 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig3 = buyTestConfig1 { mintParams = mintParams3 , expectedShares - { minMpGain = BigInt.fromInt $ 10 * 1000000 - , minSellerGain = BigInt.fromInt $ 90 * 1000000 - , minAuthorGain = BigInt.fromInt $ 90 * 1000000 + { mpGain = BigInt.fromInt $ 10 * 1000000 + , sellerGain = BigInt.fromInt $ 90 * 1000000 + , authorGain = BigInt.fromInt 0 } , testName = "low author share" } buyTestConfig4 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig4 = buyTestConfig2 - { mintParams = mintParams4, testName = "low author and marketplace shares" } + { mintParams = mintParams4 + , testName = "low author and marketplace shares" + , expectedShares + { mpGain = BigInt.fromInt 0 + , sellerGain = BigInt.fromInt $ 100 * 1000000 + , authorGain = BigInt.fromInt 0 + } + } buyTestConfig5 :: BuyTestConfig BasicBuyAssertGroup buyTestConfig5 = buyTestConfig1 @@ -151,9 +164,9 @@ buyTestConfig6 = buyTestConfig1 { mintParams = mintParams6 , testName = "fractional shares (.5)" , expectedShares - { minMpGain = BigInt.fromInt $ 5_000_000 - , minSellerGain = BigInt.fromInt $ 45_000_005 - , minAuthorGain = BigInt.fromInt $ 45_000_005 + { mpGain = BigInt.fromInt 5_000_000 + , sellerGain = BigInt.fromInt 40_000_005 + , authorGain = BigInt.fromInt 5_000_000 } } @@ -162,8 +175,8 @@ buyTestConfig7 = buyTestConfig6 { mintParams = mintParams7 , testName = "fractional shares (.1)" , expectedShares - { minSellerGain = BigInt.fromInt $ 45_000_001 - , minAuthorGain = BigInt.fromInt $ 45_000_001 + { sellerGain = BigInt.fromInt 40_000_001 + , authorGain = BigInt.fromInt 5_000_000 } } @@ -172,33 +185,36 @@ buyTestConfig8 = buyTestConfig6 { mintParams = mintParams8 , testName = "fractional shares (.9)" , expectedShares - { minSellerGain = BigInt.fromInt $ 45_000_009 - , minAuthorGain = BigInt.fromInt $ 45_000_009 + { sellerGain = BigInt.fromInt 40_000_009 + , authorGain = BigInt.fromInt 5_000_000 } } -addNftToBuyerVariants - :: Array (BuyTestConfig BasicBuyAssertGroup) +addVariants + :: (BuyTestConfig BasicBuyAssertGroup -> BuyTestConfig BasicBuyAssertGroup) + -> Array (BuyTestConfig BasicBuyAssertGroup) -> Array (BuyTestConfig BasicBuyAssertGroup) -addNftToBuyerVariants = Array.uncons >>> case _ of +addVariants vary = Array.uncons >>> case _ of Nothing -> [] Just { head: conf, tail: confs } -> - conf - : conf - { retBehaviour = ToCaller - , assertions = nftToBuyerAssert - , testName = conf.testName <> ", nft to buyer" - } - : addNftToBuyerVariants confs + conf : vary conf : addVariants vary confs -authorNotSellerVariant - :: BuyTestConfig BasicBuyAssertGroup - -> (ExpectedShares -> ExpectedShares) - -> BuyTestConfig BasicBuyAssertGroup -authorNotSellerVariant conf updateShares = +addNftToBuyerVariants + :: Array (BuyTestConfig BasicBuyAssertGroup) + -> Array (BuyTestConfig BasicBuyAssertGroup) +addNftToBuyerVariants = addVariants \conf -> conf - { expectedShares = updateShares conf.expectedShares - , authorIsSeller = false + { retBehaviour = ToCaller + , assertions = nftToBuyerAssert + , testName = conf.testName <> ", nft to buyer" + } + +addAuthorNotSellerVariants + :: Array (BuyTestConfig BasicBuyAssertGroup) + -> Array (BuyTestConfig BasicBuyAssertGroup) +addAuthorNotSellerVariants = addVariants \conf -> + conf + { authorIsSeller = false , testName = conf.testName <> ", author is not seller" } @@ -207,44 +223,21 @@ suite = only $ group "Buy" do let tests = - [ buyTestConfig5 - -- Specify rounding behaviour - , buyTestConfig6 - , authorNotSellerVariant buyTestConfig6 _ - { minSellerGain = BigInt.fromInt $ 40_000_005 - , minAuthorGain = BigInt.fromInt $ 5_000_000 - } - , buyTestConfig7 - , authorNotSellerVariant buyTestConfig7 _ - { minSellerGain = BigInt.fromInt $ 40_000_001 - , minAuthorGain = BigInt.fromInt $ 5_000_000 - } - , buyTestConfig8 - , authorNotSellerVariant buyTestConfig8 _ - { minSellerGain = BigInt.fromInt $ 40_000_009 - , minAuthorGain = BigInt.fromInt $ 5_000_000 - } - ] <> - addNftToBuyerVariants - [ buyTestConfig1 - , authorNotSellerVariant buyTestConfig1 _ - { minSellerGain = BigInt.fromInt $ 80 * 1000000 - , minAuthorGain = BigInt.fromInt $ 10 * 1000000 - } - , buyTestConfig2 - , authorNotSellerVariant buyTestConfig2 _ - { minSellerGain = BigInt.fromInt $ 90 * 1000000 - , minAuthorGain = BigInt.fromInt $ 10 * 1000000 - } - , buyTestConfig3 - , authorNotSellerVariant buyTestConfig3 _ - { minSellerGain = BigInt.fromInt $ 90 * 1000000 - , minAuthorGain = BigInt.fromInt $ 0 - } - , buyTestConfig4 - , authorNotSellerVariant buyTestConfig4 _ - { minAuthorGain = BigInt.fromInt $ 0 } + [ buyTestConfig5 ] + <> addAuthorNotSellerVariants + [ + -- Specify rounding behaviour + buyTestConfig6 + , buyTestConfig7 + , buyTestConfig8 ] + <> + (addNftToBuyerVariants <<< addAuthorNotSellerVariants) + [ buyTestConfig1 + , buyTestConfig2 + , buyTestConfig3 + , buyTestConfig4 + ] for_ tests mkBuyTest mkBuyTest @@ -253,14 +246,14 @@ mkBuyTest => BuyTestConfig f -> TestPlanM Unit mkBuyTest - conf@{ mintParams, expectedShares, retBehaviour, assertions, authorIsSeller } = + conf@{ mintParams, retBehaviour, assertions, authorIsSeller } = (if conf.skip then skip else if conf.only then only else identity) $ test conf.testName $ (if conf.shouldError then expectError else identity) $ runBuyTest mintParams retBehaviour authorIsSeller \b -> -- TODO: check tx metadata - mkShareAssertions expectedShares b /\ mkDatumAssertions /\ assertions + mkUtxoAssertions conf b /\ assertions nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) nftToMarketPlaceAssert o@{ mpScriptAddr } = @@ -283,38 +276,41 @@ assertAddrLacksOldAsset addr { txData } = =<< not <$> checkNftAtAddress txData.oldAsset addr -mkDatumAssertions :: PostBuyTestData -> Array (Contract () Unit) -mkDatumAssertions - { sellerPayAddr, authorPayAddr, mpScriptAddr, txData: { oldAsset } } = - let - datum = Datum $ toData oldAsset - in - -- TODO: check that these utxos have the expected payment amounts - -- TODO: account for cases where shares were too low - [ assertContract "Seller did not have payment utxo with datum" =<< - checkUtxoWithDatum "seller" datum sellerPayAddr - , assertContract "Author did not have payment utxo with datum" =<< - checkUtxoWithDatum "author" datum authorPayAddr - , assertContract "Marketplace did not have payment utxo with datum" =<< - checkUtxoWithDatum "marketplace" datum mpScriptAddr - ] - -mkShareAssertions - :: ExpectedShares +mkUtxoAssertions + :: forall f + . WrappingAssertion f () PostBuyTestData + => BuyTestConfig f -> BuyTestData - -> Array (ContractWrapAssertion () PostBuyTestData) -mkShareAssertions - e@{ minSellerGain, minAuthorGain } + -> ContractWrapAssertion () PostBuyTestData +mkUtxoAssertions + { authorIsSeller, expectedShares: e@{ sellerGain, authorGain } } b@{ sellerPayAddr, authorPayAddr } = - [ assertGainAtAddr' "Author" authorPayAddr minAuthorGain - , assertGainAtAddr' "Seller" sellerPayAddr minSellerGain - , buyerMarketplaceShareAssert e b - ] + let + assertSellerChange = assertGainAtAddr' "Seller" sellerPayAddr + $ if authorIsSeller then sellerGain + authorGain else sellerGain + assertAuthorChange = + if authorIsSeller then identity + else assertGainAtAddr' "Author" authorPayAddr authorGain + assertSellerPayment = assertPaymentUtxo "Seller" sellerPayAddr sellerGain + assertAuthorPayment = + if authorIsSeller then const (pure unit) + else assertPaymentUtxo "Author" authorPayAddr authorGain + in + withAssertions + $ + [ assertSellerChange + , assertAuthorChange + , buyerMarketplaceUtxoAssert e b + ] + /\ + [ assertAuthorPayment + , assertSellerPayment + ] -buyerMarketplaceShareAssert +buyerMarketplaceUtxoAssert :: ExpectedShares -> BuyTestData -> ContractWrapAssertion () PostBuyTestData -buyerMarketplaceShareAssert - { minMpGain } +buyerMarketplaceUtxoAssert + { mpGain } { buyerAddr , mpScriptAddr , mintParams: MintParams mintParams @@ -337,11 +333,26 @@ buyerMarketplaceShareAssert mpRemainder = mpInit - feeLovelace pure $ if nftToBuyer then price - mpRemainder else price + feeLovelace - mpExp = if nftToBuyer then (minMpGain - mpInit) else minMpGain - contract `wrapAndAssert` - [ assertGainAtAddr' "Marketplace" mpScriptAddr mpExp - , assertLossAtAddr "Buyer" buyerAddr getBuyerExpectedLoss - ] + mpExp = if nftToBuyer then (mpGain - mpInit) else mpGain + wrapAndAssert contract + $ + [ assertGainAtAddr' "Marketplace" mpScriptAddr mpExp + , assertLossAtAddr "Buyer" buyerAddr getBuyerExpectedLoss + ] + /\ + [ assertPaymentUtxo "Marketplace" mpScriptAddr mpGain + ] + +assertPaymentUtxo + :: String -> Address -> BigInt -> PostBuyTestData -> Contract () Unit +assertPaymentUtxo name addr payment { txData: { oldAsset } } + | payment < minAdaOnlyUTxOValue = pure unit + | otherwise = + assertContract (name <> " did not have payment utxo with datum") + =<< isJust + <$> findUtxo addr \o@(TransactionOutput utxo) -> + checkOutputHasDatum name (Datum $ toData oldAsset) (==) o <#> + (_ && valueToLovelace utxo.amount == payment) runBuyTest :: forall (f :: Type) diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 2abc386..525cb2b 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -18,6 +18,7 @@ module Test.Contract.Util , checkUtxoWithDatum , class WrappingAssertion , findM + , findUtxo , findUtxoWithDatum , findUtxoWithNft , mintParams1 @@ -28,6 +29,7 @@ module Test.Contract.Util , mintParams6 , mintParams7 , mintParams8 + , mkExpectedVsActual , plutipConfig , privateStakeKey1 , privateStakeKey2 @@ -490,9 +492,17 @@ findUtxoWithDatum -> a -> Address -> Contract r (Maybe TransactionOutput) -findUtxoWithDatum utxoName datum addr = do +findUtxoWithDatum utxoName datum addr = + findUtxo addr (checkOutputHasDatum utxoName datum (==)) + +findUtxo + :: forall (r :: Row Type) + . Address + -> (TransactionOutput -> Contract r Boolean) + -> Contract r (Maybe TransactionOutput) +findUtxo addr p = do utxos <- liftedM "Could not get utxos" $ map unwrap <$> utxosAt addr - findM (checkOutputHasDatum utxoName datum (==)) utxos + findM p utxos findM :: forall (a :: Type) (f :: Type -> Type) (m :: Type -> Type) diff --git a/test/Plutip.purs b/test/Plutip.purs index 392278c..0856546 100644 --- a/test/Plutip.purs +++ b/test/Plutip.purs @@ -14,7 +14,7 @@ main :: Effect Unit main = launchAff_ $ interpretWithConfig -- we don't want to exit because we need to clean up after failure by -- timeout (something likely to happen with plutip tests) - defaultConfig { timeout = Just $ wrap 30_000.0, exit = false } + defaultConfig { timeout = Just $ wrap 60_000.0, exit = false } plutipTestPlan plutipTestPlan :: TestPlanM Unit From 6122b4846814dbc56d76d2ea0f38c3fe3068b36b Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Wed, 24 Aug 2022 11:11:07 -0600 Subject: [PATCH 23/27] Add test for buy tx metadata --- test/Contract/Buy.purs | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 0e70d02..1c7866a 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -3,7 +3,7 @@ module Test.Contract.Buy (suite) where import Contract.Prelude import Contract.Address (Address, getWalletAddress) -import Contract.Monad (Contract, liftedM) +import Contract.Monad (Contract, liftContractE, liftedM) import Contract.Numeric.Natural as Nat import Contract.PlutusData (Datum(..), toData) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) @@ -27,17 +27,19 @@ import Seabug.Contract.Buy (marketplaceBuy') import Seabug.Contract.Util ( ReturnBehaviour(..) , SeabugTxData + , getSeabugMetadata , minAdaOnlyUTxOValue , modify ) import Seabug.MarketPlace (marketplaceValidatorAddr) -import Seabug.Types (MintParams(..)) +import Seabug.Types (MintParams(..), NftData(..)) import Test.Contract.Util ( class WrappingAssertion , ContractWrapAssertion , assertContract , assertGainAtAddr' , assertLossAtAddr + , assertTxHasMetadata , callMintCnft , callMintSgNft , checkNftAtAddress @@ -74,12 +76,14 @@ type BuyTestData' (r :: Row Type) = , mintParams :: MintParams -- The params used to mint the bought nft , sgNft :: CurrencySymbol /\ TokenName -- The nft being bought , nftToBuyer :: Boolean -- Whether the nft is being sent directly to the buyer + , preBuyNft :: NftData | r } type PostBuyTestData = BuyTestData' ( txData :: SeabugTxData -- The data of the buy transaction , txHash :: TransactionHash -- The hash of the buy transaction + , postBuyNft :: NftData ) type ExpectedShares = @@ -251,9 +255,13 @@ mkBuyTest $ test conf.testName $ (if conf.shouldError then expectError else identity) $ runBuyTest mintParams retBehaviour authorIsSeller - \b -> - -- TODO: check tx metadata - mkUtxoAssertions conf b /\ assertions + \b -> mkUtxoAssertions conf b /\ assertions /\ buyTxMetadataAssert + +buyTxMetadataAssert :: PostBuyTestData -> Contract () Unit +buyTxMetadataAssert { txHash, txData: { newAsset }, postBuyNft } = do + expectedSeabugMetadata <- liftContractE $ + getSeabugMetadata postBuyNft (fst newAsset) + assertTxHasMetadata "Buy" txHash expectedSeabugMetadata nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) nftToMarketPlaceAssert o@{ mpScriptAddr } = @@ -410,8 +418,13 @@ runBuyTest mintParams retBehaviour authorIsSeller getAssertions = do , nftToBuyer: case retBehaviour of ToCaller -> true _ -> false + , preBuyNft: nftData } void $ withAssertions (getAssertions buyTestData) do txHash /\ txData <- marketplaceBuy' retBehaviour nftData awaitTxConfirmed txHash - pure $ merge buyTestData { txData, txHash } + pure $ merge buyTestData + { txData + , txHash + , postBuyNft: modify (_ { nftId = txData.newNft }) nftData + } From e52cbc0fa28298c5f65ab16d3563e04780d18344 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Wed, 24 Aug 2022 11:53:12 -0600 Subject: [PATCH 24/27] Documentation --- test/Contract/Buy.purs | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 1c7866a..e42a3b2 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -32,7 +32,7 @@ import Seabug.Contract.Util , modify ) import Seabug.MarketPlace (marketplaceValidatorAddr) -import Seabug.Types (MintParams(..), NftData(..)) +import Seabug.Types (MintParams(..), NftData) import Test.Contract.Util ( class WrappingAssertion , ContractWrapAssertion @@ -76,14 +76,14 @@ type BuyTestData' (r :: Row Type) = , mintParams :: MintParams -- The params used to mint the bought nft , sgNft :: CurrencySymbol /\ TokenName -- The nft being bought , nftToBuyer :: Boolean -- Whether the nft is being sent directly to the buyer - , preBuyNft :: NftData + , preBuyNft :: NftData -- The data of the nft being bought | r } type PostBuyTestData = BuyTestData' ( txData :: SeabugTxData -- The data of the buy transaction , txHash :: TransactionHash -- The hash of the buy transaction - , postBuyNft :: NftData + , postBuyNft :: NftData -- The data of the nft after it was bought ) type ExpectedShares = @@ -257,33 +257,42 @@ mkBuyTest $ runBuyTest mintParams retBehaviour authorIsSeller \b -> mkUtxoAssertions conf b /\ assertions /\ buyTxMetadataAssert +-- | Assert that the buy tx metadata is correct buyTxMetadataAssert :: PostBuyTestData -> Contract () Unit buyTxMetadataAssert { txHash, txData: { newAsset }, postBuyNft } = do expectedSeabugMetadata <- liftContractE $ getSeabugMetadata postBuyNft (fst newAsset) assertTxHasMetadata "Buy" txHash expectedSeabugMetadata +-- | Invariants for when the nft is sent to the marketplace after a +-- | buy nftToMarketPlaceAssert :: PostBuyTestData -> Array (Contract () Unit) nftToMarketPlaceAssert o@{ mpScriptAddr } = [ assertAddrHasNewAsset mpScriptAddr o , assertAddrLacksOldAsset mpScriptAddr o ] +-- | Invariants for when the nft is sent to the buyer after a buy nftToBuyerAssert :: PostBuyTestData -> Array (Contract () Unit) nftToBuyerAssert o@{ buyerAddr, mpScriptAddr } = [ assertAddrHasNewAsset buyerAddr o, assertAddrLacksOldAsset mpScriptAddr o ] +-- | Assert that the address holds the post-buy updated nft assertAddrHasNewAsset :: Address -> PostBuyTestData -> Contract () Unit assertAddrHasNewAsset addr { txData } = assertContract "Address did not contain new sgNft" =<< checkNftAtAddress txData.newAsset addr +-- | Assert that the address does not hold the pre-buy nft assertAddrLacksOldAsset :: Address -> PostBuyTestData -> Contract () Unit assertAddrLacksOldAsset addr { txData } = assertContract "Address contained old sgNft" =<< not <$> checkNftAtAddress txData.oldAsset addr +-- | Build assertions for the invariants surrounding the utxos of the +-- | buy transaction, including: correct distribution of +-- | royalties/shares, and correct payment utxos with datums mkUtxoAssertions :: forall f . WrappingAssertion f () PostBuyTestData @@ -315,6 +324,11 @@ mkUtxoAssertions , assertSellerPayment ] +-- | Makes a check for the invariants of the buyer's and the +-- | marketplace's utxos surrounding a buy. This is separated into its +-- | own function to handle the special case of the buyer not paying +-- | the full price, described here: +-- | https://github.com/mlabs-haskell/seabug-contracts/pull/41#issue-1322730466 buyerMarketplaceUtxoAssert :: ExpectedShares -> BuyTestData -> ContractWrapAssertion () PostBuyTestData buyerMarketplaceUtxoAssert @@ -351,6 +365,8 @@ buyerMarketplaceUtxoAssert [ assertPaymentUtxo "Marketplace" mpScriptAddr mpGain ] +-- | Assert that the given address has a utxo with the given lovelace +-- | amount and the correct payment datum. assertPaymentUtxo :: String -> Address -> BigInt -> PostBuyTestData -> Contract () Unit assertPaymentUtxo name addr payment { txData: { oldAsset } } @@ -362,6 +378,10 @@ assertPaymentUtxo name addr payment { txData: { oldAsset } } checkOutputHasDatum name (Datum $ toData oldAsset) (==) o <#> (_ && valueToLovelace utxo.amount == payment) +-- | With three actors: Author, Seller, and Buyer, first have Author +-- | mint a token, second optionally have Seller buy that token, and +-- | third have Buyer buy the token. The third step is wrapped in the +-- | given assertions. runBuyTest :: forall (f :: Type) . WrappingAssertion f () PostBuyTestData From dfd9de20f8f6597a232832b88401d88e5c28eddb Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Tue, 30 Aug 2022 09:00:27 -0600 Subject: [PATCH 25/27] Update CTL server to develop --- flake.lock | 108 +++++++++++++++++----------------- flake.nix | 15 +++-- package-lock.json | 2 +- packages.dhall | 6 +- spago-packages.nix | 6 +- src/Seabug/CallContract.purs | 12 ++-- src/Seabug/Contract/Util.purs | 6 +- test/Contract/Minting.purs | 4 +- test/Contract/Util.purs | 15 +++-- 9 files changed, 88 insertions(+), 86 deletions(-) diff --git a/flake.lock b/flake.lock index a6ba6d1..1d4e714 100644 --- a/flake.lock +++ b/flake.lock @@ -107,17 +107,17 @@ "typed-protocols": "typed-protocols_2" }, "locked": { - "lastModified": 1658231641, - "narHash": "sha256-WlyKzl+MvzKLSC21XZLNb5ZJdxJdLhLmFZZqwzTstzQ=", + "lastModified": 1660654407, + "narHash": "sha256-P1U5guPrx9QTUz3aQG2EjgnMgRyqYzQojw4tC9W29O8=", "owner": "mlabs-haskell", "repo": "bot-plutus-interface", - "rev": "e6e0c4aa81c7e5e6c109c18675759457d5fbbce2", + "rev": "7ac4f6fe11ae32edc5d5894077fedcd552e180b8", "type": "github" }, "original": { "owner": "mlabs-haskell", "repo": "bot-plutus-interface", - "rev": "e6e0c4aa81c7e5e6c109c18675759457d5fbbce2", + "rev": "7ac4f6fe11ae32edc5d5894077fedcd552e180b8", "type": "github" } }, @@ -192,17 +192,17 @@ "cardano-addresses_2": { "flake": false, "locked": { - "lastModified": 1655809189, - "narHash": "sha256-hYAvI7KlFnFRjMG8/JvDl733YnQUE1O26VMcr94h0oM=", + "lastModified": 1660105670, + "narHash": "sha256-91F9+ckA3lBCE4dAVLDnMSpwRLa7zRUEEBYEHv0sOYk=", "owner": "input-output-hk", "repo": "cardano-addresses", - "rev": "b6f2f3cef01a399376064194fd96711a5bdba4a7", + "rev": "b7273a5d3c21f1a003595ebf1e1f79c28cd72513", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-addresses", - "rev": "b6f2f3cef01a399376064194fd96711a5bdba4a7", + "rev": "b7273a5d3c21f1a003595ebf1e1f79c28cd72513", "type": "github" } }, @@ -395,17 +395,17 @@ "cardano-ledger_3": { "flake": false, "locked": { - "lastModified": 1657127204, - "narHash": "sha256-4wcSA61TwoDTvJ6rx7tjEAJjQLO/cs8WGTHcOghNdTc=", + "lastModified": 1659038626, + "narHash": "sha256-zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI=", "owner": "input-output-hk", "repo": "cardano-ledger", - "rev": "3be8a19083fc13d9261b1640e27dd389b51bb08e", + "rev": "c7c63dabdb215ebdaed8b63274965966f2bf408f", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-ledger", - "rev": "3be8a19083fc13d9261b1640e27dd389b51bb08e", + "rev": "c7c63dabdb215ebdaed8b63274965966f2bf408f", "type": "github" } }, @@ -446,17 +446,17 @@ "cardano-node_3": { "flake": false, "locked": { - "lastModified": 1657227628, - "narHash": "sha256-CP58qcHZJGYq1FzXCj8ll085TvnJoYMeXnVGVGLYH/w=", + "lastModified": 1659625017, + "narHash": "sha256-4IrheFeoWfvkZQndEk4fGUkOiOjcVhcyXZ6IqmvkDgg=", "owner": "input-output-hk", "repo": "cardano-node", - "rev": "c75451f0ffd7a60b5ad6c4263891e6c8acac105a", + "rev": "950c4e222086fed5ca53564e642434ce9307b0b9", "type": "github" }, "original": { "owner": "input-output-hk", + "ref": "1.35.3-rc1", "repo": "cardano-node", - "rev": "c75451f0ffd7a60b5ad6c4263891e6c8acac105a", "type": "github" } }, @@ -566,17 +566,17 @@ "servant-purescript": "servant-purescript_2" }, "locked": { - "lastModified": 1660663244, - "narHash": "sha256-y+RAgaJZ2gQct0EIE8/0040Z4IvA9HktmcfOAWVOyeY=", + "lastModified": 1661841189, + "narHash": "sha256-Tnnxm4r36xZZFEG37K+CRCXNwJ4DTAj1Iw+3IsBNzKg=", "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "058eeed77b472231e34e8c994be071f4196a0b2f", + "rev": "09540ea3915be20e5095b3b6f2418ddd712eb58e", "type": "github" }, "original": { "owner": "Plutonomicon", "repo": "cardano-transaction-lib", - "rev": "058eeed77b472231e34e8c994be071f4196a0b2f", + "rev": "09540ea3915be20e5095b3b6f2418ddd712eb58e", "type": "github" } }, @@ -600,17 +600,17 @@ "cardano-wallet_2": { "flake": false, "locked": { - "lastModified": 1657745277, - "narHash": "sha256-+PrfQH6m7ROpHKNyo54MzLrL31tIvSZUQYnbBT70ekc=", + "lastModified": 1660141505, + "narHash": "sha256-3Rnj/g3KLzOW5YSieqsUa9IF1Td22Eskk5KuVsOFgEQ=", "owner": "input-output-hk", "repo": "cardano-wallet", - "rev": "2ac308b00d9d4a3435f6b9594ded9495e2b217eb", + "rev": "18a931648550246695c790578d4a55ee2f10463e", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-wallet", - "rev": "2ac308b00d9d4a3435f6b9594ded9495e2b217eb", + "rev": "18a931648550246695c790578d4a55ee2f10463e", "type": "github" } }, @@ -1006,17 +1006,17 @@ "hedgehog-extras_2": { "flake": false, "locked": { - "lastModified": 1647260073, - "narHash": "sha256-TR9i1J3HUYz3QnFQbfJPr/kGDahxZPojDsorYtRZeGU=", + "lastModified": 1656051321, + "narHash": "sha256-6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE=", "owner": "input-output-hk", "repo": "hedgehog-extras", - "rev": "967d79533c21e33387d0227a5f6cc185203fe658", + "rev": "714ee03a5a786a05fc57ac5d2f1c2edce4660d85", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "hedgehog-extras", - "rev": "967d79533c21e33387d0227a5f6cc185203fe658", + "rev": "714ee03a5a786a05fc57ac5d2f1c2edce4660d85", "type": "github" } }, @@ -1073,17 +1073,17 @@ "hw-aeson": { "flake": false, "locked": { - "lastModified": 1649341404, - "narHash": "sha256-xO4/zPMBmZtBXFwHF8p3nw4TilrJHxH54mfg9CRnuO8=", + "lastModified": 1660113261, + "narHash": "sha256-v0SyVxeVBTtW1tuej4P+Kf4roO/rr2tBI7RthTlInbc=", "owner": "haskell-works", "repo": "hw-aeson", - "rev": "d99d2f3e39a287607418ae605b132a3deb2b753f", + "rev": "b5ef03a7d7443fcd6217ed88c335f0c411a05408", "type": "github" }, "original": { "owner": "haskell-works", "repo": "hw-aeson", - "rev": "d99d2f3e39a287607418ae605b132a3deb2b753f", + "rev": "b5ef03a7d7443fcd6217ed88c335f0c411a05408", "type": "github" } }, @@ -1511,17 +1511,17 @@ "unstable_nixpkgs": "unstable_nixpkgs" }, "locked": { - "lastModified": 1659358988, - "narHash": "sha256-YKabPu9FDvUNmSR7+MNwLwiURv4lWQr13r1CuoS3qhM=", + "lastModified": 1660314631, + "narHash": "sha256-5GxToZTZIPQPBhqrJXU4tAdLIPeBHNiBQY2KTSGJfFg=", "owner": "mlabs-haskell", "repo": "ogmios-datum-cache", - "rev": "47f01a1d9f7dc5cc5246c0c228e5cf5f5ba44399", + "rev": "880a69a03fbfd06a4990ba8873f06907d4cd16a7", "type": "github" }, "original": { "owner": "mlabs-haskell", "repo": "ogmios-datum-cache", - "rev": "47f01a1d9f7dc5cc5246c0c228e5cf5f5ba44399", + "rev": "880a69a03fbfd06a4990ba8873f06907d4cd16a7", "type": "github" } }, @@ -1630,17 +1630,17 @@ "ouroboros-network_3": { "flake": false, "locked": { - "lastModified": 1654820431, - "narHash": "sha256-bmLD5sFsiny/eRv6MHrqGvo6I4QG9pO0psiHWGFZqro=", + "lastModified": 1658339771, + "narHash": "sha256-3ElbHM1B5u1QD0aes1KbaX2FxKJzU05H0OzJ36em1Bg=", "owner": "input-output-hk", "repo": "ouroboros-network", - "rev": "a65c29b6a85e90d430c7f58d362b7eb097fd4949", + "rev": "cb9eba406ceb2df338d8384b35c8addfe2067201", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "ouroboros-network", - "rev": "a65c29b6a85e90d430c7f58d362b7eb097fd4949", + "rev": "cb9eba406ceb2df338d8384b35c8addfe2067201", "type": "github" } }, @@ -1669,17 +1669,17 @@ ] }, "locked": { - "lastModified": 1658235706, - "narHash": "sha256-T5E4Qz/6ZlxVVJer6j5xFKvY4XGJPMbZsVxac8RbZ9w=", + "lastModified": 1660730745, + "narHash": "sha256-N1HOR3rqsXMIG7k12BsIyVZReJM9jHUW+gfvYBq/p84=", "owner": "mlabs-haskell", "repo": "plutip", - "rev": "d24b98162bcbcbfb4ca403ee62fdb890f2059f47", + "rev": "8364c43ac6bc9ea140412af9a23c691adf67a18b", "type": "github" }, "original": { "owner": "mlabs-haskell", "repo": "plutip", - "rev": "d24b98162bcbcbfb4ca403ee62fdb890f2059f47", + "rev": "8364c43ac6bc9ea140412af9a23c691adf67a18b", "type": "github" } }, @@ -1703,34 +1703,34 @@ "plutus-apps": { "flake": false, "locked": { - "lastModified": 1658170029, - "narHash": "sha256-/G3CrE2aXrhytDGOqhifmIT31gJcvI3FjuntztOi8DY=", - "owner": "gege251", + "lastModified": 1660652339, + "narHash": "sha256-0lCjJWMHYCFW62B5QAmkPakqNWdj2hJBqQP4AWHjBFE=", + "owner": "mikekeke", "repo": "plutus-apps", - "rev": "62342808fa7422ebea3233a7e031d3aa00c04672", + "rev": "efdb04b602ade22245769f7e52d07475b3e8c339", "type": "github" }, "original": { - "owner": "gege251", + "owner": "mikekeke", "repo": "plutus-apps", - "rev": "62342808fa7422ebea3233a7e031d3aa00c04672", + "rev": "efdb04b602ade22245769f7e52d07475b3e8c339", "type": "github" } }, "plutus_2": { "flake": false, "locked": { - "lastModified": 1656585904, - "narHash": "sha256-ATwDR5LX2RN9YfoPhTxV7REvFoJnM4x/CN9XZVZlalg=", + "lastModified": 1659046871, + "narHash": "sha256-coD/Kpl7tutwXb6ukQCH5XojBjquYkW7ob0BWZtdpok=", "owner": "input-output-hk", "repo": "plutus", - "rev": "69ab98c384703172f898eb5bcad1078ded521426", + "rev": "a56c96598b4b25c9e28215214d25189331087244", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "plutus", - "rev": "69ab98c384703172f898eb5bcad1078ded521426", + "rev": "a56c96598b4b25c9e28215214d25189331087244", "type": "github" } }, diff --git a/flake.nix b/flake.nix index cb5b4a8..427364d 100644 --- a/flake.nix +++ b/flake.nix @@ -12,8 +12,8 @@ repo = "cardano-transaction-lib"; # should be same rev as in packages.dhall # To update, do `spago2nix generate` - # `calum/fix-slot-length-type` branch - rev = "058eeed77b472231e34e8c994be071f4196a0b2f"; + # `develop` branch + rev = "09540ea3915be20e5095b3b6f2418ddd712eb58e"; }; nixpkgs.follows = "cardano-transaction-lib/nixpkgs"; }; @@ -25,11 +25,9 @@ nixpkgsFor = system: import nixpkgs { inherit system; overlays = [ - cardano-transaction-lib.overlay - (_: _: { - ctl-server = - cardano-transaction-lib.packages.${system}."ctl-server:exe:ctl-server"; - }) + cardano-transaction-lib.overlays.purescript + cardano-transaction-lib.overlays.ctl-server + cardano-transaction-lib.overlays.runtime ]; }; psProjectFor = system: @@ -79,6 +77,7 @@ seabug-contracts-plutip-test = project.runPlutipTest { name = "seabug-contracts-plutip-test"; testMain = "Test.Plutip"; + withCtlServer = true; env = {}; }; formatting-check = pkgs.runCommand "formatting-check" @@ -100,7 +99,7 @@ packages = {inherit (self.packages) x86_64-linux;}; devShells = {inherit (self.devShell) x86_64-linux;}; }; - + check = perSystem (system: (nixpkgsFor system).runCommand "combined-test" { diff --git a/package-lock.json b/package-lock.json index 1f3da96..c1c6cd3 100644 --- a/package-lock.json +++ b/package-lock.json @@ -2400,7 +2400,7 @@ "isobject": { "version": "3.0.1", "resolved": "https://registry.npmjs.org/isobject/-/isobject-3.0.1.tgz", - "integrity": "sha512-WhB9zCku7EGTj/HQQRz5aUQEUeoQZH2bWcltRErOpymJ4boYE6wL9Tbr23krRPSZ+C5zqNSrSw+Cc7sZZ4b7vg==", + "integrity": "sha1-TkMekrEalzFjaqH5yNHMvP2reN8=", "dev": true }, "jest-worker": { diff --git a/packages.dhall b/packages.dhall index e9b4d0b..0f3d841 100644 --- a/packages.dhall +++ b/packages.dhall @@ -312,6 +312,7 @@ let additions = , "js-date" , "lattice" , "lists" + , "math" , "maybe" , "medea" , "media-types" @@ -326,9 +327,9 @@ let additions = , "node-process" , "node-streams" , "nonempty" - , "optparse" , "now" , "numbers" + , "optparse" , "ordered-collections" , "orders" , "parallel" @@ -344,6 +345,7 @@ let additions = , "rationals" , "record" , "refs" + , "safe-coerce" , "spec" , "spec-quickcheck" , "strings" @@ -363,7 +365,7 @@ let additions = ] , repo = "https://github.com/Plutonomicon/cardano-transaction-lib.git" -- should be same rev as in flake.nix - , version = "058eeed77b472231e34e8c994be071f4196a0b2f" + , version = "09540ea3915be20e5095b3b6f2418ddd712eb58e" } } in upstream // additions diff --git a/spago-packages.nix b/spago-packages.nix index cd9954a..15e3bdc 100644 --- a/spago-packages.nix +++ b/spago-packages.nix @@ -211,11 +211,11 @@ let "cardano-transaction-lib" = pkgs.stdenv.mkDerivation { name = "cardano-transaction-lib"; - version = "058eeed77b472231e34e8c994be071f4196a0b2f"; + version = "09540ea3915be20e5095b3b6f2418ddd712eb58e"; src = pkgs.fetchgit { url = "https://github.com/Plutonomicon/cardano-transaction-lib.git"; - rev = "058eeed77b472231e34e8c994be071f4196a0b2f"; - sha256 = "1rn99rjh3kn7k4npkx60igh1k3fkyk7i6221nwf09njrla0l1r6b"; + rev = "09540ea3915be20e5095b3b6f2418ddd712eb58e"; + sha256 = "1a6c9p025dqg4gshhk03kv0cs9a4hapyrds12icidszpiadz2yaf"; }; phases = "installPhase"; installPhase = "ln -s $src $out"; diff --git a/src/Seabug/CallContract.purs b/src/Seabug/CallContract.purs index 6bbac14..637dec5 100644 --- a/src/Seabug/CallContract.purs +++ b/src/Seabug/CallContract.purs @@ -230,13 +230,15 @@ buildContractConfig cfg = do , path: Nothing } , ctlServerConfig: - { port: serverPort - , host: cfg.serverHost - , secure: cfg.serverSecureConn - , path: Nothing - } + Just + { port: serverPort + , host: cfg.serverHost + , secure: cfg.serverSecureConn + , path: Nothing + } , networkId: networkId , logLevel: logLevel + , suppressLogs: true , extraConfig: {} , walletSpec: Nothing , customLogger: Nothing diff --git a/src/Seabug/Contract/Util.purs b/src/Seabug/Contract/Util.purs index 71b623f..65e48d8 100644 --- a/src/Seabug/Contract/Util.purs +++ b/src/Seabug/Contract/Util.purs @@ -20,11 +20,7 @@ import Contract.PlutusData , toData , unitRedeemer ) -import Contract.ScriptLookups - ( ScriptLookups - , UnattachedUnbalancedTx - , mkUnbalancedTx - ) +import Contract.ScriptLookups (ScriptLookups, mkUnbalancedTx) import Contract.ScriptLookups ( ScriptLookups , mintingPolicy diff --git a/test/Contract/Minting.purs b/test/Contract/Minting.purs index b3c59c6..06956d6 100644 --- a/test/Contract/Minting.purs +++ b/test/Contract/Minting.purs @@ -7,7 +7,7 @@ import Contract.Chain (currentSlot) import Contract.Monad (liftContractE, liftedM) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) import Data.BigInt as BigInt -import Mote (only, test) +import Mote (test) import Seabug.Contract.Util (getSeabugMetadata) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (LockDatum(..), MarketplaceDatum(..)) @@ -27,7 +27,7 @@ import TestM (TestPlanM) suite :: TestPlanM Unit suite = - only $ test "Minting" do + test "Minting" do let distribution = ( withStakeKey privateStakeKey1 diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index 525cb2b..c9c62a4 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -167,7 +167,9 @@ plutipConfig :: PlutipConfig plutipConfig = { host: "127.0.0.1" , port: UInt.fromInt 8082 - , logLevel: Error + , logLevel: Debug + , suppressLogs: true + , customLogger: Nothing , ogmiosConfig: { port: UInt.fromInt 1338 , host: "127.0.0.1" @@ -181,11 +183,12 @@ plutipConfig = , path: Nothing } , ctlServerConfig: - { port: UInt.fromInt 8083 - , host: "127.0.0.1" - , secure: false - , path: Nothing - } + Just + { port: UInt.fromInt 8083 + , host: "127.0.0.1" + , secure: false + , path: Nothing + } , postgresConfig: { host: "127.0.0.1" , port: UInt.fromInt 5433 From 2ed6687723db196e43fa8bc7e832680172d91777 Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Thu, 1 Sep 2022 10:56:53 -0600 Subject: [PATCH 26/27] Minor refactor --- test/Contract/Buy.purs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index e42a3b2..2498892 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -16,7 +16,6 @@ import Contract.Transaction , getTxByHash ) import Contract.Value (CurrencySymbol, TokenName, getLovelace) -import Data.Array ((:)) import Data.Array as Array import Data.BigInt (BigInt) import Data.BigInt as BigInt @@ -198,10 +197,7 @@ addVariants :: (BuyTestConfig BasicBuyAssertGroup -> BuyTestConfig BasicBuyAssertGroup) -> Array (BuyTestConfig BasicBuyAssertGroup) -> Array (BuyTestConfig BasicBuyAssertGroup) -addVariants vary = Array.uncons >>> case _ of - Nothing -> [] - Just { head: conf, tail: confs } -> - conf : vary conf : addVariants vary confs +addVariants vary = Array.foldMap (\x -> [ x, vary x ]) addNftToBuyerVariants :: Array (BuyTestConfig BasicBuyAssertGroup) From 781097eef73d717fbf39a96b01735f70ac6c786c Mon Sep 17 00:00:00 2001 From: Calum Sieppert Date: Thu, 1 Sep 2022 11:00:39 -0600 Subject: [PATCH 27/27] Tests for incorrect mint txs --- src/Seabug/Contract/CnftMint.purs | 21 ++++++- src/Seabug/Contract/Mint.purs | 25 ++++++-- test/Contract/Buy.purs | 6 +- test/Contract/Minting.purs | 100 +++++++++++++++++++++++++----- test/Contract/Util.purs | 23 ++++--- 5 files changed, 140 insertions(+), 35 deletions(-) diff --git a/src/Seabug/Contract/CnftMint.purs b/src/Seabug/Contract/CnftMint.purs index cce040d..1ad7f24 100644 --- a/src/Seabug/Contract/CnftMint.purs +++ b/src/Seabug/Contract/CnftMint.purs @@ -1,4 +1,7 @@ -module Seabug.Contract.CnftMint where +module Seabug.Contract.CnftMint + ( mintCnft + , mintCnftTest + ) where import Contract.Prelude @@ -35,7 +38,18 @@ mintCnft :: forall (r :: Row Type) . MintCnftParams -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName)) -mintCnft (MintCnftParams params) = do +mintCnft = mintCnftTest pure + +-- | Cnft mint contract with an option to modify the tx constraints, +-- | for testing purposes. +mintCnftTest + :: forall (r :: Row Type) + . ( Constraints.TxConstraints Void Void + -> Contract r (Constraints.TxConstraints Void Void) + ) + -> MintCnftParams + -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName)) +mintCnftTest modConstraints (MintCnftParams params) = do owner <- liftedM "Cannot get PaymentPubKeyHash" ownPaymentPubKeyHash ownerStake <- liftedM "Cannot get StakePubKeyHash" ownStakePubKeyHash networkId <- getNetworkId @@ -68,7 +82,8 @@ mintCnft (MintCnftParams params) = do , Constraints.mustSpendPubKeyOutput oref , Constraints.mustPayToPubKeyAddress owner ownerStake value ] - unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints + unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups + =<< modConstraints constraints policyHash <- liftedM "Could not get minting policy hash" $ liftAff $ mintingPolicyHash policy name <- liftContractM "Invalid CIP25 NFT name. The name is probably too long." diff --git a/src/Seabug/Contract/Mint.purs b/src/Seabug/Contract/Mint.purs index 96d8d45..c136b26 100644 --- a/src/Seabug/Contract/Mint.purs +++ b/src/Seabug/Contract/Mint.purs @@ -1,6 +1,7 @@ module Seabug.Contract.Mint ( mintWithCollection , mintWithCollection' + , mintWithCollectionTest ) where import Contract.Prelude @@ -41,18 +42,20 @@ import Seabug.Types , NftId(..) ) --- | Mint the self-governed NFT for the given collection, and return --- | sgNft's asset class and nft data. -mintWithCollection' +mintWithCollectionTest :: forall (r :: Row Type) . CurrencySymbol /\ TokenName -> MintParams + -> ( Constraints.TxConstraints Void Void + -> Contract r (Constraints.TxConstraints Void Void) + ) -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName) /\ NftData) -mintWithCollection' +mintWithCollectionTest (collectionNftCs /\ collectionNftTn) ( MintParams { price, lockLockup, lockLockupEnd, authorShare, daoShare } - ) = do + ) + modConstraints = do owner <- liftedM "Cannot get PaymentPubKeyHash" ownPaymentPubKeyHash ownerStake <- liftedM "Cannot get StakePubKeyHash" ownStakePubKeyHash networkId <- getNetworkId @@ -106,7 +109,8 @@ mintWithCollection' ) $ singleton collectionNftCs collectionNftTn one , Constraints.mustValidateIn $ from now ] - unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups constraints + unbalancedTx <- liftedE $ Lookups.mkUnbalancedTx lookups + =<< modConstraints constraints let nftData = NftData { nftId: nft, nftCollection: collection } metadata <- liftContractE $ getSeabugMetadata nftData curr unbalancedTxWithMetadata <- setTxMetadata unbalancedTx metadata @@ -116,6 +120,15 @@ mintWithCollection' <> show transactionHash pure $ transactionHash /\ (curr /\ tn) /\ nftData +-- | Mint the self-governed NFT for the given collection, and return +-- | sgNft's asset class and nft data. +mintWithCollection' + :: forall (r :: Row Type) + . CurrencySymbol /\ TokenName + -> MintParams + -> Contract r (TransactionHash /\ (CurrencySymbol /\ TokenName) /\ NftData) +mintWithCollection' c p = mintWithCollectionTest c p pure + -- | Mint the self-governed NFT for the given collection. mintWithCollection :: forall (r :: Row Type) diff --git a/test/Contract/Buy.purs b/test/Contract/Buy.purs index 2498892..1add105 100644 --- a/test/Contract/Buy.purs +++ b/test/Contract/Buy.purs @@ -220,7 +220,7 @@ addAuthorNotSellerVariants = addVariants \conf -> suite :: TestPlanM Unit suite = - only $ group "Buy" do + group "Buy" do let tests = [ buyTestConfig5 ] @@ -410,8 +410,8 @@ runBuyTest mintParams retBehaviour authorIsSeller getAssertions = do authorPayAddr <- walletEnterpriseAddress "author" author sellerPayAddr <- walletEnterpriseAddress "seller" seller { sgNft: initialSgNft, nftData: initialNftData } <- withKeyWallet author do - cnft <- callMintCnft - callMintSgNft cnft mintParams + cnft <- callMintCnft pure + callMintSgNft cnft mintParams pure sgNft /\ nftData <- if authorIsSeller then pure $ initialSgNft /\ initialNftData else withKeyWallet seller do diff --git a/test/Contract/Minting.purs b/test/Contract/Minting.purs index 06956d6..906572a 100644 --- a/test/Contract/Minting.purs +++ b/test/Contract/Minting.purs @@ -4,11 +4,19 @@ import Contract.Prelude import Contract.Address (getWalletAddress, scriptHashAddress) import Contract.Chain (currentSlot) -import Contract.Monad (liftContractE, liftedM) +import Contract.Log (logError') +import Contract.Monad (Contract, liftContractE, liftedM) +import Contract.Scripts (validatorHash) import Contract.Test.Plutip (runPlutipContract, withKeyWallet, withStakeKey) +import Contract.TxConstraints (TxConstraint(..), TxConstraints(..)) +import Contract.Utxos (utxosAt) +import Contract.Value (lovelaceValueOf) +import Contract.Wallet (KeyWallet) import Data.BigInt as BigInt -import Mote (test) -import Seabug.Contract.Util (getSeabugMetadata) +import Data.FoldableWithIndex (findWithIndex) +import Mote (group, test) +import Seabug.Contract.Util (getSeabugMetadata, minAdaOnlyUTxOValue, modify) +import Seabug.Lock (mkLockScript) import Seabug.MarketPlace (marketplaceValidatorAddr) import Seabug.Types (LockDatum(..), MarketplaceDatum(..)) import Test.Contract.Util @@ -23,27 +31,78 @@ import Test.Contract.Util , plutipConfig , privateStakeKey1 ) +import Test.Spec.Assertions (expectError) import TestM (TestPlanM) suite :: TestPlanM Unit suite = - test "Minting" do - let - distribution = - ( withStakeKey privateStakeKey1 - [ BigInt.fromInt 1_000_000_000 - , BigInt.fromInt 2_000_000_000 - ] - ) - runPlutipContract plutipConfig distribution \alice -> - withKeyWallet alice do - cnft <- callMintCnft + group "Minting" do + test "Cnft mint fail: expect \"UTxO not consumed\" trace" $ expectError $ + withMinter \_ -> do + addr <- liftedM "Could not get addr" getWalletAddress + utxos <- liftedM "Cannot get user utxos" $ map unwrap <$> utxosAt addr + callMintCnft \txc@(TxConstraints { constraints }) -> do + constraints' <- for constraints $ + case _ of + MustSpendPubKeyOutput oref -> do + oref' <- findWithIndex (\i _ -> i /= oref) utxos # case _ of + Nothing -> do + logError' + "Could not find a utxo different from the constraint" + pure oref + Just { index: oref' } -> pure oref' + pure $ MustSpendPubKeyOutput oref' + x -> pure x + pure $ modify (_ { constraints = constraints' }) txc + + group "SgNft mint fail" do + test "expect \"Exactly one NFT must be minted\" trace" $ + expectError do + withMinter \_ -> do + cnft <- callMintCnft pure + callMintSgNft cnft mintParams1 + \txc@(TxConstraints { constraints }) -> do + constraints' <- for constraints $ + case _ of + (MustMintValue h r t i) + | i == one -> pure $ + MustMintValue h r t (BigInt.fromInt 2) + x -> pure x + pure $ modify (_ { constraints = constraints' }) txc + test "expect \"Underlying NFT must be locked\" trace" $ + expectError do + withMinter \_ -> do + let + mp = mintParams1 + mp' = unwrap mp + cnft <- callMintCnft pure + lockingScript <- mkLockScript (fst cnft) mp'.lockLockup + mp'.lockLockupEnd + lockingScriptHash <- liftedM "Could not get locking script hash" + $ liftAff + $ validatorHash lockingScript + callMintSgNft cnft mp + \txc@(TxConstraints { constraints }) -> do + constraints' <- for constraints $ + case _ of + -- Modify the constraint sending the underlying + -- nft to the locking script to not send it + (MustPayToScript h d _) + | h == lockingScriptHash -> pure $ + MustPayToScript h d + (lovelaceValueOf minAdaOnlyUTxOValue) + x -> pure x + pure $ modify (_ { constraints = constraints' }) txc + + test "Successful mint" do + withMinter \_ -> do + cnft <- callMintCnft pure aliceAddr <- liftedM "Could not get addr" getWalletAddress assertContract "Could not find cnft at user address" =<< checkNftAtAddress cnft aliceAddr expectedEntered <- currentSlot - { sgNft, nftData, txHash } <- callMintSgNft cnft mintParams1 + { sgNft, nftData, txHash } <- callMintSgNft cnft mintParams1 pure scriptAddr <- marketplaceValidatorAddr sgNftUtxo <- @@ -78,4 +137,13 @@ suite = getSeabugMetadata nftData (fst sgNft) assertTxHasMetadata "sgNft" txHash expectedSeabugMetadata - pure unit +withMinter + :: forall (a :: Type). (KeyWallet -> Contract () a) -> Aff a +withMinter f = + runPlutipContract plutipConfig + ( withStakeKey privateStakeKey1 + [ BigInt.fromInt 1_000_000_000 + , BigInt.fromInt 2_000_000_000 + ] + ) + \minter -> withKeyWallet minter (f minter) diff --git a/test/Contract/Util.purs b/test/Contract/Util.purs index c9c62a4..5699d1a 100644 --- a/test/Contract/Util.purs +++ b/test/Contract/Util.purs @@ -63,6 +63,7 @@ import Contract.Transaction , awaitTxConfirmed , getTxByHash ) +import Contract.TxConstraints as Constraints import Contract.Utxos (utxosAt) import Contract.Value ( CurrencySymbol @@ -84,8 +85,8 @@ import Effect.Exception (throw) import Metadata.FromMetadata (class FromMetadata, fromMetadata) import Metadata.MetadataType (class MetadataType, metadataLabel) import Partial.Unsafe (unsafePartial) -import Seabug.Contract.CnftMint (mintCnft) -import Seabug.Contract.Mint (mintWithCollection') +import Seabug.Contract.CnftMint (mintCnftTest) +import Seabug.Contract.Mint (mintWithCollectionTest) import Seabug.Contract.Util (modify) import Seabug.Types (MintCnftParams(..), MintParams, NftData) import Type.Proxy (Proxy(..)) @@ -129,10 +130,14 @@ mintParams8 :: MintParams mintParams8 = modify (_ { price = Nat.fromInt' 50_000_009 }) mintParams1 callMintCnft - ∷ forall (r :: Row Type). Contract r (CurrencySymbol /\ TokenName) -callMintCnft = do + ∷ forall (r :: Row Type) + . ( Constraints.TxConstraints Void Void + -> Contract r (Constraints.TxConstraints Void Void) + ) + -> Contract r (CurrencySymbol /\ TokenName) +callMintCnft modConstraints = do log "Minting cnft..." - txHash /\ cnft <- mintCnft $ + txHash /\ cnft <- mintCnftTest modConstraints $ MintCnftParams { imageUri: "ipfs://k2cwuebwvb6kdiwob6sb2yqnz38r0yv72q1xijbts9ep5lq3nm8rw3i4" @@ -150,14 +155,18 @@ callMintSgNft :: forall (r :: Row Type) . Tuple CurrencySymbol TokenName -> MintParams + -> ( Constraints.TxConstraints Void Void + -> Contract r (Constraints.TxConstraints Void Void) + ) -> Contract r { sgNft :: (CurrencySymbol /\ TokenName) , nftData :: NftData , txHash :: TransactionHash } -callMintSgNft cnft mintParams = do +callMintSgNft cnft mintParams modConstraints = do log "Minting sgNft..." - txHash /\ sgNft /\ nftData <- mintWithCollection' cnft mintParams + txHash /\ sgNft /\ nftData <- + mintWithCollectionTest cnft mintParams modConstraints log $ "Waiting for confirmation of nft transaction: " <> show txHash awaitTxConfirmed txHash log $ "Nft transaction confirmed: " <> show txHash