diff --git a/.devcontainer/ devcontainer.json b/.devcontainer/ devcontainer.json new file mode 100644 index 000000000..59310ba02 --- /dev/null +++ b/.devcontainer/ devcontainer.json @@ -0,0 +1,23 @@ +{ + "name": "Plutus Starter Project", + "image": "docker.io/inputoutput/plutus-starter-devcontainer:v1.0.14", + + "remoteUser": "plutus", + + "mounts": [ + // This shares cabal's remote repository state with the host. We don't mount the whole of '.cabal', because + // 1. '.cabal/config' contains absolute paths that will only make sense on the host, and + // 2. '.cabal/store' is not necessarily portable to different version of cabal etc. + "source=${localEnv:HOME}/.cabal/packages,target=/home/plutus/.cabal/packages,type=bind,consistency=cached", + ], + + "settings": { + // Note: don't change from bash so it runs .bashrc + "terminal.integrated.shell.linux": "/bin/bash" + }, + + // IDs of extensions inside container + "extensions": [ + "haskell.haskell" + ], +} \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/.gitignore b/MetaLamp/nft-marketplace/.gitignore new file mode 100644 index 000000000..c817e9858 --- /dev/null +++ b/MetaLamp/nft-marketplace/.gitignore @@ -0,0 +1,28 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +.psc-ide-port +config/plutus-pab.local.yaml +config/chain-index-config.local.json +deployment/env/env.local.sh + diff --git a/MetaLamp/nft-marketplace/LICENSE b/MetaLamp/nft-marketplace/LICENSE new file mode 100644 index 000000000..261eeb9e9 --- /dev/null +++ b/MetaLamp/nft-marketplace/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/MetaLamp/nft-marketplace/Makefile b/MetaLamp/nft-marketplace/Makefile new file mode 100644 index 000000000..98a26028c --- /dev/null +++ b/MetaLamp/nft-marketplace/Makefile @@ -0,0 +1,2 @@ +fmt: + fix-stylish-haskell diff --git a/MetaLamp/nft-marketplace/README.md b/MetaLamp/nft-marketplace/README.md new file mode 100644 index 000000000..bff3e3fc2 --- /dev/null +++ b/MetaLamp/nft-marketplace/README.md @@ -0,0 +1,73 @@ +# NFT Marketplace + +[The description and specification of a project](Spec.md) + +## Setting up + +- Install nix +- Clone https://github.com/input-output-hk/plutus +- Set up your machine to build things with Nix, following the Plutus README (make sure to set up the binary cache!) + +## The Plutus Application Backend (PAB) usage + +We have provided two PAB applications in `./pab` and `./pab-simulation`. The first one is made for real world usage and interaction through frontend [client](client/README.md), the second one is a big test scenario. +With the PAB we can serve and interact with contracts over a web API. You can read more about the PAB here: [PAB Architecture](https://github.com/input-output-hk/plutus/blob/master/plutus-pab/ARCHITECTURE.adoc). + +1. Enter the nix shell (from `nft-marketplace` directory): + +``` +nix-shell +``` + +2. Build the PAB executables (cd to plutus-use-cases/MetaLamp/nft-marketplace): + +``` +cabal build all +``` + +3. Run the PAB binary: + +``` +cabal run pab +``` + +This will then start up the server on port 8080. + +4. To run test simulation do: + +``` +cabal run pab-simulation +``` + +## IPFS + +1. Install IPFS daemon following the [instruction](https://docs.ipfs.io/install/command-line/#official-distributions) + +2. To initialize the repository using to store IPFS settings, run: + +``` +ipfs init +``` + +3. Set up the `CORS` settings: + +``` +ipfs config --json API.HTTPHeaders.Access-Control-Allow-Origin '["webui://-", "http://localhost:3000", "http://127.0.0.1:5001", "https://webui.ipfs.io", "https://localhost:8009", "http://localhost:8009"]' +``` + +``` +ipfs config --json API.HTTPHeaders.Access-Control-Allow-Methods '["PUT", "POST"]' +``` + +4. Run IPFS server: + +``` +ipfs daemon +``` + +## Client + +See the client [readme](client/README.md). +## Protocol functionality + +See the description of user endpoints [here](src/Plutus/Contracts/NftMarketplace/Endpoints.hs) diff --git a/MetaLamp/nft-marketplace/Spec.md b/MetaLamp/nft-marketplace/Spec.md new file mode 100644 index 000000000..4fa52b3fc --- /dev/null +++ b/MetaLamp/nft-marketplace/Spec.md @@ -0,0 +1,92 @@ +# NFT Marketplace + +## Brief description + +NFT Marketplace Service enables to create NFT tokens for any file and put them on sale or auction. Marketplace allows combining NFT tokens into bundles and operate them as a single unit when sell or buy it. + +## Monetization + +The marketplace operator receives a fee from: + +- Fixed fee by NFT minting +- Fixed fee by NFTs bundling +- Percentage by NFT price on the Sale +- Percentage by final bid on the Auction + +## Glossary + +**Bundle** - a collection of tokens provided as a single unit. + +**Sale** - a protocol when NFT owner sets a fix price for NFT and opens sale for NFT buyers. NFT seller can close the sale if NFT isn't bought at that moment. It works for bundles as well. + +**Auction** - a protocol when NFT owner puts up an NFT for auction by 0 Ada and sets a timeout of auction's duration. NFT bidders can bid their price before the timeout. The winner is the bidder who made a last bid. If there are no bids on timeout, NFT returns to its seller. It works for bundles as well. + +**Marketplace tips** - a marketplace provider profits by carrying auctions and sales. + +## Users categories + +**Marketplace provider** - an actor who started a marketplace smart contract + +**NFT owner** - an actor who owns NFT token + +**NFT seller** - an NFT owner who put his NFT up to the sale or auction + +**NFT buyer/NFT bidder** - an actor who tries to buy an NFT on the Sale/make a bid on the auction + +## System architecture + +![alt tag](readme-src/NFTMarketplaceArchitecture.png) + +## Example of the flow + +![alt tag](readme-src/NFTMarketplaceFlow.png) + +## Features list + +### Marketplace owner API + +`start()` - Start marketplace smart contract. + +### Marketplace user + +`createNft()` - Mint NFT token and add it to the marketplace. + +`addNft()` - Add NFT from another marketplace that uses the same minting protocol ([IPFS content id as a token name](#implementation-features)). + +`openSale()` - Puts NFT on sale. + +`buyItem()` - Buy NFT. + +`closeSale()` - Close sale and receive token back. + +`startAnAuction()` - Start an auction for specified NFT. + +`completeAnAuction()` - Complete auction before the timeout. + +`bundleUp()` - Create a bundle from specified NFTs. + +`unbundle()` - Unbundle specified NFTs. + +`ownPubKey()` - Get `pubKeyHash` for public key belonging to the wallet of a marketplace provider. + +`ownPubKeyBalance()` - Get balance on marketplace provider address. + +### Marketplace info + +`fundsAt()` - Get all UTxOs belonging to a user. + +`marketplaceFunds()` - Get all UTxOs belonging to the Marketplace. + +`marketplaceStore()` - Get current marketplace store state. + +`getAuctionState()` - Get current auction state for specified NFT + +## Implementation details + +The main features are related to uploading a file and minting NFT. + +- **Uniqueness of an uploaded file:** Using IPFS - [Content-addressable Storage](https://en.wikipedia.org/wiki/Content-addressable_storage) to store uploading files, that guarantee the uniqueness of a linked file. `IPFS content id (cId)` link is used to link the NFT with file in a storage. + +- **Availability of cId:** `CId` is available in NFT owner's wallet - it is used as a token name. Using a `cId` as a token name is a requirement for this marketplace implementation. NFT can be imported from another marketplace, only if that requirement was abided. + +- **Privacy of cId link:** Using `cId` hash for the token name in on-chain code, to hide the NFT token until NFT owner decide to make it public putting it up on the sale or auction. diff --git a/MetaLamp/nft-marketplace/cabal.project b/MetaLamp/nft-marketplace/cabal.project new file mode 100644 index 000000000..3881ae532 --- /dev/null +++ b/MetaLamp/nft-marketplace/cabal.project @@ -0,0 +1,262 @@ +index-state: 2021-08-14T00:00:00Z + +packages: ./. + +-- You never, ever, want this. +write-ghc-environment-files: never + +-- Always build tests and benchmarks. +tests: true +benchmarks: true + +-- Plutus revision from 2021/11/05 +source-repository-package + type: git + location: https://github.com/input-output-hk/plutus-apps.git + subdir: + doc + freer-extras + playground-common + plutus-chain-index + plutus-chain-index-core + plutus-contract + plutus-ledger + plutus-pab + plutus-playground-server + plutus-use-cases + quickcheck-dynamic + web-ghc + tag: v2021-11-22 + + +-- The following sections are copied from the 'plutus-apps' repository cabal.project at the revision +-- given above. +-- This is necessary because the 'plutus-apps' libraries depend on a number of other libraries which are +-- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to +-- re-update this section from the template when you do an upgrade. + +-- We never, ever, want this. +write-ghc-environment-files: never + +-- Always build tests and benchmarks. +tests: true +benchmarks: true + +-- The only sensible test display option +test-show-details: streaming + +allow-newer: + -- Copied from plutus-core + size-based:template-haskell + , ouroboros-consensus-byron:formatting + , beam-core:aeson + , beam-sqlite:aeson + , beam-sqlite:dlist + , beam-migrate:aeson + +-- Copied from plutus-core +constraints: + -- big breaking change here, inline-r doens't have an upper bound + singletons < 3.0 + -- bizarre issue: in earlier versions they define their own 'GEq', in newer + -- ones they reuse the one from 'some', but there isn't e.g. a proper version + -- constraint from dependent-sum-template (which is the library we actually use). + , dependent-sum > 0.6.2.0 + +-- These packages appear in our dependency tree and are very slow to build. +-- Empirically, turning off optimization shaves off ~50% build time. +-- It also mildly improves recompilation avoidance. +-- For deve work we don't care about performance so much, so this is okay. +package cardano-ledger-alonzo + optimization: False +package ouroboros-consensus-shelley + optimization: False +package ouroboros-consensus-cardano + optimization: False +package cardano-api + optimization: False + +-- Copied from plutus-core +source-repository-package + type: git + location: https://github.com/Quid2/flat.git + tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 + +-- TODO replace with something more sustainable (and maintained) +source-repository-package + type: git + location: https://github.com/input-output-hk/purescript-bridge.git + tag: 366fc70b341e2633f3ad0158a577d52e1cd2b138 + +source-repository-package + type: git + location: https://github.com/input-output-hk/servant-purescript.git + tag: ebea59c7bdfc0338d83fca772b9a57e28560bcde + +-- Copied from plutus-core +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-crypto.git + tag: 07397f0e50da97eaa0575d93bee7ac4b2b2576ec + +-- Copied from plutus-core +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-base + tag: 4ea7e2d927c9a7f78ddc69738409a5827ab66b98 + subdir: + base-deriving-via + binary + binary/test + cardano-crypto-class + cardano-crypto-praos + cardano-crypto-tests + measures + orphans-deriving-via + slotting + strict-containers + +-- Copied from plutus-core +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-prelude + tag: fd773f7a58412131512b9f694ab95653ac430852 + subdir: + cardano-prelude + cardano-prelude-test + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-addresses + tag: d2f86caa085402a953920c6714a0de6a50b655ec + subdir: + core + command-line + +source-repository-package + type: git + location: https://github.com/j-mueller/cardano-wallet + tag: 6be73ab852c0592713dfe78218856d4a8a0ee69e + subdir: + lib/text-class + lib/strict-non-empty-containers + lib/core + lib/test-utils + lib/numeric + lib/launcher + lib/core-integration + lib/cli + lib/shelley + +source-repository-package + type: git + location: https://github.com/input-output-hk/ouroboros-network + tag: 1f4973f36f689d6da75b5d351fb124d66ef1057d + subdir: + monoidal-synchronisation + typed-protocols + typed-protocols-cborg + typed-protocols-examples + ouroboros-network + ouroboros-network-testing + ouroboros-network-framework + ouroboros-consensus + ouroboros-consensus-byron + ouroboros-consensus-cardano + ouroboros-consensus-shelley + io-sim + io-classes + network-mux + ntp-client + +source-repository-package + type: git + location: https://github.com/input-output-hk/iohk-monitoring-framework + -- Important Note: Read below, before changing this! + tag: 46f994e216a1f8b36fe4669b47b2a7011b0e153c + -- Are you thinking of updating this tag to some other commit? Please + -- ensure that the commit you are about to use is the latest one from + -- the *develop* branch of this repo: + -- * + -- (not master!) + -- + -- In particular we rely on the code from this PR: + -- * + -- being merged. + subdir: + iohk-monitoring + tracer-transformers + contra-tracer + plugins/backend-aggregation + plugins/backend-ekg + plugins/backend-monitoring + plugins/backend-trace-forwarder + plugins/scribe-systemd + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger-specs + tag: bf008ce028751cae9fb0b53c3bef20f07c06e333 + subdir: + byron/ledger/impl + cardano-ledger-core + cardano-protocol-tpraos + eras/alonzo/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/crypto/test + eras/byron/ledger/executable-spec + eras/byron/ledger/impl/test + eras/shelley/impl + eras/shelley-ma/impl + eras/shelley/chain-and-ledger/executable-spec + eras/shelley/test-suite + shelley/chain-and-ledger/shelley-spec-ledger-test + libs/non-integral + libs/small-steps + libs/cardano-ledger-pretty + semantics/small-steps-test + +-- A lot of plutus-apps dependencies have to be synchronized with the dependencies of +-- cardano-node. If you update cardano-node, please make sure that all dependencies +-- of cardano-node are also updated. +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-node.git + tag: b6ca519f97a0e795611a63174687e6bb70c9f752 + subdir: + cardano-api + cardano-node + cardano-cli + cardano-config + +source-repository-package + type: git + location: https://github.com/input-output-hk/optparse-applicative + tag: 7497a29cb998721a9068d5725d49461f2bba0e7a + +source-repository-package + type: git + location: https://github.com/input-output-hk/Win32-network + tag: 3825d3abf75f83f406c1f7161883c438dac7277d + +source-repository-package + type: git + location: https://github.com/input-output-hk/goblins + tag: cde90a2b27f79187ca8310b6549331e59595e7ba + +-- A lot of plutus-apps dependencies have to be syncronized with the dependencies of +-- plutus. If you update plutus, please make sure that all dependencies of plutus +-- are also updated +source-repository-package + type: git + location: https://github.com/input-output-hk/plutus + tag: 3f089ccf0ca746b399c99afe51e063b0640af547 + subdir: + plutus-core + plutus-ledger-api + plutus-tx + plutus-tx-plugin + word-array + prettyprinter-configurable + stubs/plutus-ghc-stub diff --git a/MetaLamp/nft-marketplace/config/chain-index-config.template.json b/MetaLamp/nft-marketplace/config/chain-index-config.template.json new file mode 100644 index 000000000..2a41d86fe --- /dev/null +++ b/MetaLamp/nft-marketplace/config/chain-index-config.template.json @@ -0,0 +1,19 @@ +{ + "cicSlotConfig": { + "scSlotLength": 1000, + "scSlotZeroTime": 1596059091000 + }, + "cicPort": 9083, + "cicSecurityParam": 2160, + "cicSocketPath": "/configuration/sockets/node.socket", + "cicDbPath": "/chain-index.db", + "cicNetworkId": { + "contents": { + "unNetworkMagic": 1097911063 + }, + "tag": "Testnet" + }, + "cicStoreFrom": { + "unBlockNo": 0 + } + } \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/config/plutus-pab.template.yaml b/MetaLamp/nft-marketplace/config/plutus-pab.template.yaml new file mode 100644 index 000000000..e622717bd --- /dev/null +++ b/MetaLamp/nft-marketplace/config/plutus-pab.template.yaml @@ -0,0 +1,55 @@ +dbConfig: + dbConfigFile: /pab-core.db + dbConfigPoolSize: 20 + +pabWebserverConfig: + baseUrl: http://localhost:9080 + staticDir: ./dist + permissiveCorsPolicy: False + # Optional timeout (in seconds) for calls to endpoints that are not currently + # available. If this is not set, calls to unavailable endpoints fail + # immediately. + endpointTimeout: 5 + +walletServerConfig: + baseUrl: http://localhost:8090 + wallet: + getWallet: 1 + +nodeServerConfig: + mscBaseUrl: http://localhost:9082 + mscSocketPath: /configuration/sockets/node.socket + mscKeptBlocks: 100 + mscNetworkId: "1097911063" # Testnet network ID (main net = empty string) + mscSlotConfig: + scSlotZeroTime: 1596059091000 # Wednesday, July 29, 2020 21:44:51 - shelley launch time in milliseconds + scSlotLength: 1000 # In milliseconds + mscFeeConfig: + fcConstantFee: + getLovelace: 10 # Constant fee per transaction in lovelace + fcScriptsFeeFactor: 1.0 # Factor by which to multiply size-dependent scripts fee in lovelace + mscInitialTxWallets: + - getWallet: 1 + - getWallet: 2 + - getWallet: 3 + mscNodeMode: AlonzoNode + +chainIndexConfig: + ciBaseUrl: http://localhost:9083 + ciWatchedAddresses: [] + +requestProcessingConfig: + requestProcessingInterval: 1 + +signingProcessConfig: + spBaseUrl: http://localhost:9084 + spWallet: + getWallet: 1 + +metadataServerConfig: + mdBaseUrl: http://localhost:9085 + +# Optional EKG Server Config +# ---- +# monitoringConfig: +# monitoringPort: 9090 \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/default.nix b/MetaLamp/nft-marketplace/default.nix new file mode 100644 index 000000000..d8104d849 --- /dev/null +++ b/MetaLamp/nft-marketplace/default.nix @@ -0,0 +1,35 @@ +######################################################################## +# default.nix -- The top-level nix build file for plutus-starter. +# +# This file defines various attributes that are used for building and +# developing plutus-starter. +# +######################################################################## + +let + # Here a some of the various attributes for the variable 'packages': + # + # { pkgs + # plutus-starter: { + # haskell: { + # project # The Haskell project created by haskell-nix.project + # packages # All the packages defined by our project, including dependencies + # projectPackages # Just the packages in the project + # } + # hlint + # cabal-install + # stylish-haskell + # haskell-language-server + # } + # } + + packages = import ./nix; + + inherit (packages) pkgs plutus-starter; + project = plutus-starter.haskell.project; +in +{ + inherit pkgs plutus-starter; + + inherit project; +} diff --git a/MetaLamp/nft-marketplace/deployment/README.md b/MetaLamp/nft-marketplace/deployment/README.md new file mode 100644 index 000000000..81fa3c73d --- /dev/null +++ b/MetaLamp/nft-marketplace/deployment/README.md @@ -0,0 +1,76 @@ +## Testnet deployment steps: + +### Set up local environment + +- Cd to `./env` and create a file with local env variables `env.local.sh` from the `env.template.sh`. + +- export your environment variables: + +``` +source env/env.local.sh +``` + +### Run cardano-node and cardano-wallet + +Cd to the `./deployment` directory. + +If it is your first start, you haven't download testnet configs, run: + +``` +sh first-start.sh $NODE_TAG $NODE_PATH +``` + +For the next time starts run: + +``` +sh start.sh $NODE_TAG $NODE_PATH +``` + +You can enter to wallet and node containers using following commands: + +``` +docker exec -ti cardano-wallet bash + +docker exec -ti cardano-node bash +``` + +### Start chain-index + +Copy `./config/chain-index-config.template.json` to the `./config/chain-index-config.local.json`, and change to your node path directory. + +Go to the `plutus-apps` project from new terminal window and run chain-index: + +``` +cd plutus-apps + +nix build -f default.nix plutus-apps.haskell.packages.plutus-chain-index.components.exes.plutus-chain-index + +./result/bin/plutus-chain-index --config ../plutus-use-cases/MetaLamp/nft-marketplace/config/chain-index-config.local.json start-index +``` + +Sometimes the error with `node.socket` permission can occur, you can change file permissions to read, write and execute for all: + +``` +sudo chmod 777 ${NODE_PATH}/configuration/sockets/node.socket +``` + +### Set up the PAB + +Copy `./config/plutus-pab.template.yaml` to the `./config/plutus-pab.local.yaml`, and change to your node path directory. + +### Create a wallet + +Step 2 and step 3 from [document](https://gist.github.com/mikekeke/883d56c38e0237444ac98ae5257e174f). +Save a wallet passphrase, it is required for the next step. + +### Run Dapp + +Go to the `plutus-use-cases/MetaLamp/nft-marketplace`, enter the nix shell and run migrations to create pab database, then run the PAB application itself: + +``` +cabal exec pab-app -- --config ./config/plutus-pab.local.yaml migrate + +cabal exec pab-app -- --config ./config/plutus-pab.local.yaml --passphrase "WALLET_PASSPHRASE" webserver +``` + +Created on the basis of [instruction](https://gist.github.com/mikekeke/883d56c38e0237444ac98ae5257e174f). diff --git a/MetaLamp/nft-marketplace/deployment/docker-compose.yaml b/MetaLamp/nft-marketplace/deployment/docker-compose.yaml new file mode 100644 index 000000000..757612e22 --- /dev/null +++ b/MetaLamp/nft-marketplace/deployment/docker-compose.yaml @@ -0,0 +1,39 @@ +version: '3.3' +services: + cardano-node: + image: inputoutput/cardano-node:${NODE_TAG} + container_name: cardano-node + restart: always + volumes: + - ${NODE_PATH}/configuration/config:/app/cardano/config + - ${NODE_PATH}/configuration/topology:/app/cardano/topology + - ${NODE_PATH}/configuration/sockets:/app/cardano/sockets + - ${NODE_PATH}/database:/db + command: "run --topology /app/cardano/topology/testnet-topology.json --config /app/cardano/config/testnet-config.json --port 3001 --host-addr 0.0.0.0 --database-path /db --socket-path /app/cardano/sockets/node.socket" + ports: + - 3001 + environment: + - CARDANO_NODE_SOCKET_PATH=/app/cardano/sockets/node.socket + cardano-wallet: + image: inputoutput/cardano-wallet:2021.11.11 + container_name: cardano-wallet + volumes: + - ${NODE_PATH}/wallet/wallet-db:/wallet-db + - ${NODE_PATH}/configuration/sockets:/app/cardano/sockets + - ${NODE_PATH}/configuration/config:/app/cardano/config + ports: + - 8090:8090 + entrypoint: [] + command: bash -c " + ($$CMD --testnet /app/cardano/config/testnet-byron-genesis.json) + " + environment: + CMD: "cardano-wallet serve --node-socket /app/cardano/sockets/node.socket --database /wallet-db --listen-address 0.0.0.0" + NETWORK: + restart: on-failure + logging: + driver: "json-file" + options: + compress: "true" + max-file: "10" + max-size: "50m" diff --git a/MetaLamp/nft-marketplace/deployment/env/env.template.sh b/MetaLamp/nft-marketplace/deployment/env/env.template.sh new file mode 100644 index 000000000..2d1193b88 --- /dev/null +++ b/MetaLamp/nft-marketplace/deployment/env/env.template.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +export NODE_PATH="/home/cardano/testnet" # set a path to testnet configs and db +export NODE_TAG="1.30.1" # cardano-node tag diff --git a/MetaLamp/nft-marketplace/deployment/first-start.sh b/MetaLamp/nft-marketplace/deployment/first-start.sh new file mode 100644 index 000000000..f3dce2322 --- /dev/null +++ b/MetaLamp/nft-marketplace/deployment/first-start.sh @@ -0,0 +1,35 @@ +#!/bin/sh + +export NODE_TAG=$1 +export NODE_PATH=$2 + +CONFIG=https://hydra.iohk.io/build/7366583/download/1/testnet-config.json +BYRON_GENESIS=https://hydra.iohk.io/build/7366583/download/1/testnet-byron-genesis.json +SHELLEY_GENESIS=https://hydra.iohk.io/build/7366583/download/1/testnet-shelley-genesis.json +ALONZO_GENESIS=https://hydra.iohk.io/build/7366583/download/1/testnet-alonzo-genesis.json +TOPOLOGY=https://hydra.iohk.io/build/7189190/download/1/testnet-topology.json + +##Making some folders +mkdir -p ${NODE_PATH}/configuration/config/ +mkdir -p ${NODE_PATH}/configuration/topology/ +mkdir -p ${NODE_PATH}/configuration/sockets/ + +##Making DB Folder +mkdir -p ${NODE_PATH}/database/ + +##Touch for a Socket +touch ${NODE_PATH}/configuration/sockets/node.socket + +##Getting Config +echo "--getting config" +wget $CONFIG -P ${NODE_PATH}/configuration/config +wget $BYRON_GENESIS -P ${NODE_PATH}/configuration/config/ +wget $SHELLEY_GENESIS -P ${NODE_PATH}/configuration/config/ +wget $ALONZO_GENESIS -P ${NODE_PATH}/configuration/config/ + +##Getting Topology +echo "--getting topology" +wget $TOPOLOGY -P ${NODE_PATH}/configuration/topology/ + +##Starting Docker-Compose +docker-compose up diff --git a/MetaLamp/nft-marketplace/deployment/start.sh b/MetaLamp/nft-marketplace/deployment/start.sh new file mode 100644 index 000000000..6fc5cabdc --- /dev/null +++ b/MetaLamp/nft-marketplace/deployment/start.sh @@ -0,0 +1,7 @@ +#!/bin/sh + +export NODE_TAG=$1 +export NODE_PATH=$2 + +##Starting Docker-Compose +docker-compose up diff --git a/MetaLamp/nft-marketplace/generate-typescript/Main.hs b/MetaLamp/nft-marketplace/generate-typescript/Main.hs new file mode 100644 index 000000000..d1548aaf5 --- /dev/null +++ b/MetaLamp/nft-marketplace/generate-typescript/Main.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Control.Monad (when) +import Control.Monad.Reader (MonadReader) +import Data.Aeson.TypeScript.Internal +import Data.Aeson.TypeScript.TH +import qualified Data.Aeson.Types as Aeson +import Data.ByteString (ByteString) +import Data.Proxy (Proxy (Proxy)) +import Plutus.Abstract.ContractResponse (ContractState) +import qualified Plutus.Abstract.Percentage as Percentage +import Plutus.Abstract.RemoteData (RemoteData) +import Plutus.Contract.StateMachine.ThreadToken (ThreadToken) +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OffChain.Serialization as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Contracts.Services.Auction as Auction +import qualified Plutus.Contracts.Services.Sale as Sale +import Plutus.PAB.MarketplaceContracts (MarketplaceContracts (..)) +import Plutus.V1.Ledger.Ada (Ada) +import Plutus.V1.Ledger.Crypto (PubKeyHash) +import Plutus.V1.Ledger.Time (DiffMilliSeconds, + POSIXTime) +import Plutus.V1.Ledger.Tx (TxOutRef) +import Plutus.V1.Ledger.TxId (TxId) +import Plutus.V1.Ledger.Value (CurrencySymbol, + TokenName, + Value) +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Builtins.Internal (BuiltinByteString) +import System.Directory (doesDirectoryExist, + removeDirectoryRecursive) + +instance TypeScript BuiltinByteString where + getTypeScriptType _ = "string" + +instance TypeScript Marketplace.PlutusBuiltinByteString where + getTypeScriptType _ = "string" + +instance TypeScript POSIXTime where + getTypeScriptType _ = "integer" + +$(deriveTypeScript Aeson.defaultOptions ''TxOutRef) +$(deriveTypeScript Aeson.defaultOptions ''TxId) +$(deriveTypeScript Aeson.defaultOptions ''CurrencySymbol) +$(deriveTypeScript Aeson.defaultOptions ''PubKeyHash) +$(deriveTypeScript Aeson.defaultOptions ''Value) + +instance (TypeScript a, TypeScript b) => TypeScript (AssocMap.Map a b) where + getTypeScriptType _ = "AssocMap<" <> (getTypeScriptType (Proxy :: Proxy a)) <> ", " <> (getTypeScriptType (Proxy :: Proxy b)) <> ">" + getTypeScriptDeclarations _ = [TSRawDeclaration "export type AssocMap = [K, V][]"] + +$(deriveTypeScript Aeson.defaultOptions ''TokenName) +$(deriveTypeScript Aeson.defaultOptions ''Ada) + +-- TODO: write 'normally', if there is nothing else to do +instance (TypeScript a, TypeScript b) => TypeScript (RemoteData a b) where + getTypeScriptType _ = "RemoteData<" <> (getTypeScriptType (Proxy :: Proxy a)) <> ", " <> (getTypeScriptType (Proxy :: Proxy b)) <> ">" + getTypeScriptDeclarations _ = [ + TSRawDeclaration "export type RemoteData = INotAsked | ILoading | IFailure | ISuccess;", + TSRawDeclaration "export interface INotAsked { tag: \"NotAsked\"; }", + TSRawDeclaration "export interface ILoading { tag: \"Loading\"; }", + TSRawDeclaration "export interface IFailure { tag: \"Failure\"; contents: T; }", + TSRawDeclaration "export interface ISuccess { tag: \"Success\"; contents: T; }"] + +$(deriveTypeScript Aeson.defaultOptions ''ThreadToken) +$(deriveTypeScript Aeson.defaultOptions ''DiffMilliSeconds) +$(deriveTypeScript Aeson.defaultOptions ''MarketplaceContracts) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.Marketplace) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.LotLink) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.MarketplaceDatum) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.UserItemId) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.UserContractState) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.InfoContractState) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.OwnerContractState) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.NftInfo) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.NFT) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.Bundle) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.BundleInfo) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.NftBundle) +$(deriveTypeScript Aeson.defaultOptions ''Auction.Auction) +$(deriveTypeScript Aeson.defaultOptions ''Auction.AuctionState) +$(deriveTypeScript Aeson.defaultOptions ''Auction.HighestBid) +$(deriveTypeScript Aeson.defaultOptions ''Auction.AuctionFee) +$(deriveTypeScript Aeson.defaultOptions ''Sale.Sale) +$(deriveTypeScript Aeson.defaultOptions ''Sale.SaleFee) +$(deriveTypeScript Aeson.defaultOptions ''Percentage.Percentage) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.CreateNftParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.OpenSaleParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.CloseLotParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.StartAnAuctionParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.BidOnAuctionParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.BundleUpParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.UnbundleParams) +$(deriveTypeScript Aeson.defaultOptions ''Marketplace.MarketplaceSettingsInfo) +$(deriveTypeScript Aeson.defaultOptions ''ContractState) + +formattingOptions :: FormattingOptions +formattingOptions = FormattingOptions + { numIndentSpaces = 2 + , interfaceNameModifier = id + , typeNameModifier = id + , exportMode = ExportEach + , typeAlternativesFormat = TypeAlias + } + +main :: IO () +main = writeFile "generated.ts" $ formatTSDeclarations' formattingOptions ( + (getTypeScriptDeclarations (Proxy @ThreadToken)) <> + (getTypeScriptDeclarations (Proxy @DiffMilliSeconds)) <> + (getTypeScriptDeclarations (Proxy @MarketplaceContracts)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.Marketplace)) <> + (getTypeScriptDeclarations (Proxy @(RemoteData T1 T2))) <> + (getTypeScriptDeclarations (Proxy @(ContractState T1 T2 T3))) <> + (getTypeScriptDeclarations (Proxy @Marketplace.LotLink)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.MarketplaceDatum)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.UserItemId)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.OwnerContractState)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.UserContractState)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.InfoContractState)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.NftInfo)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.NFT)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.Bundle)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.BundleInfo)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.NftBundle)) <> + (getTypeScriptDeclarations (Proxy @Auction.Auction)) <> + (getTypeScriptDeclarations (Proxy @Auction.AuctionState)) <> + (getTypeScriptDeclarations (Proxy @Auction.HighestBid)) <> + (getTypeScriptDeclarations (Proxy @Auction.AuctionFee)) <> + (getTypeScriptDeclarations (Proxy @Sale.Sale)) <> + (getTypeScriptDeclarations (Proxy @Sale.SaleFee)) <> + (getTypeScriptDeclarations (Proxy @Percentage.Percentage)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.CreateNftParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.OpenSaleParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.CloseLotParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.StartAnAuctionParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.BidOnAuctionParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.BundleUpParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.UnbundleParams)) <> + (getTypeScriptDeclarations (Proxy @Marketplace.MarketplaceSettingsInfo)) <> + (getTypeScriptDeclarations (Proxy @TxOutRef)) <> + (getTypeScriptDeclarations (Proxy @TxId)) <> + (getTypeScriptDeclarations (Proxy @CurrencySymbol)) <> + (getTypeScriptDeclarations (Proxy @PubKeyHash)) <> + (getTypeScriptDeclarations (Proxy @Value)) <> + (getTypeScriptDeclarations (Proxy @TokenName)) <> + (getTypeScriptDeclarations (Proxy @Ada)) <> + (getTypeScriptDeclarations (Proxy @(AssocMap.Map T1 T2))) <> + (getTypeScriptDeclarations (Proxy @(Either T1 T2)))) diff --git a/MetaLamp/nft-marketplace/hie.yaml b/MetaLamp/nft-marketplace/hie.yaml new file mode 100644 index 000000000..04cd24395 --- /dev/null +++ b/MetaLamp/nft-marketplace/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/MetaLamp/nft-marketplace/nix/default.nix b/MetaLamp/nft-marketplace/nix/default.nix new file mode 100644 index 000000000..cd68c45e4 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/default.nix @@ -0,0 +1,20 @@ +let + # Pratically, the only needed dependency is the plutus repository. + sources = import ./sources.nix { inherit pkgs; }; + + # We're going to get everything from the main plutus repository. This ensures + # we're using the same version of multiple dependencies such as nipxkgs, + # haskell-nix, cabal-install, compiler-nix-name, etc. + plutus = import sources.plutus-apps {}; + pkgs = plutus.pkgs; + + haskell-nix = pkgs.haskell-nix; + + plutus-starter = import ./pkgs { + inherit pkgs haskell-nix sources plutus; + }; + +in +{ + inherit pkgs plutus-starter; +} \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/nix/lib/ci.nix b/MetaLamp/nft-marketplace/nix/lib/ci.nix new file mode 100644 index 000000000..80794a750 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/lib/ci.nix @@ -0,0 +1,201 @@ +{ pkgs }: + +let + # Generic nixpkgs, use *only* for lib functions that are stable across versions + lib = pkgs.lib; +in +rec { + # Borrowed from https://github.com/cachix/ghcide-nix/pull/4/files#diff-70bfff902f4dec33e545cac10ee5844d + # Tweaked to use builtins.mapAttrs instead of needing the one from nixpkgs lib + /* + dimension: name -> attrs -> function -> attrs + where + function: keyText -> value -> attrsOf package + + WARNING: Attribute names must not contain periods ("."). + See https://github.com/NixOS/nix/issues/3088 + + NOTE: The dimension name will be picked up by agent and web ui soon. + + Specifies a dimension of the build matrix. For example + + dimension "Example" { + withP = { p = true; } + withoutP = { p = false; } + } (key: # either "withP" or "withoutP" + { p }: # either p = true or p = false + myProject p + ) + + evaluates roughly to + + { + withP = myProject true; + withoutP = myProject false; + } + + Use nested calls for multiple dimensions. + + Example: + + dimension "System" { + "x86_64-linux" = {}; + # ... + }: (system: {}: + + dimension "Nixpkgs release" ( + { + "nixpkgs-19_03".nixpkgs = someSource + } // optionalAttrs (system != "...") { + "nixpkgs-unstable".nixpkgs = someOtherSource + } + ) (_key: { nixpkgs }: + + myProject system nixpkgs + + ) + ) + + evaluates roughly to + + { + x86_64-linux.nixpkgs-19_03 = myProject "x86_64-linux" someSource; + x86_64-linux.nixpkgs-unstable = myProject "x86_64-linux" someOtherSource; + ... + } + + If you need to make references across attributes, you can do so by binding + the result. Wherever you write + + dimension "My dimension" {} (key: value: f1 key value) + + You can also write + + let + myDimension = dimension "My dimension" {} (key: value: f2 key value myDimension) + in + myDimension + + This example builds a single test runner to reuse across releases: + + let + overlay = + testRunnerPkgs: self: super: { + # ... + }; + myProject = + { nixpkgs, + pkgs ? import nixpkgs { overlays = [ overlay ]; }, + testRunnerPkgs ? pkgs + }: pkgs; + in + + let + latest = "nixpkgs-19_03"; + releases = + dimension "Nixpkgs release" + { + nixpkgs-18_09.nixpkgs = someSource + nixpkgs-19_03.nixpkgs = someOtherSource + } + (_key: { nixpkgs }: + + myProject { + inherit nixpkgs; + testRunnerPkgs = releases."${latest}"; + } + + ); + in releases; + + */ + dimension = name: attrs: f: + builtins.mapAttrs + (k: v: + let o = f k v; + in o // { recurseForDerivations = o.recurseForDerivations or true; } + ) + attrs + // { meta.dimension.name = name; }; + + /* + Takes an attribute set and returns all the paths to derivations within it, i.e. + derivationPaths { a = { b = ; }; c = ; } == [ "a.b" "c" ] + This can be used with 'attrByPath' or the 'constitutents' of an aggregate Hydra job. + */ + derivationPaths = + let + names = x: lib.filter (n: n != "recurseForDerivations" && n != "meta") (builtins.attrNames x); + go = nameSections: attrs: + builtins.concatMap + (n: + let + v = builtins.getAttr n attrs; + newNameSections = nameSections ++ [ n ]; + in + if pkgs.lib.isDerivation v + then [ (builtins.concatStringsSep "." newNameSections) ] + else if builtins.isAttrs v + then go newNameSections v + else [ ] + ) + (names attrs); + in + go [ ]; + + # Creates an aggregate job with the given name from every derivation in the attribute set. + derivationAggregate = name: attrs: pkgs.releaseTools.aggregate { + inherit name; + constituents = derivationPaths attrs; + }; + + # A filter for removing packages that aren't supported on the current platform + # according to 'meta.platforms'. + platformFilterGeneric = pkgs: system: + # This needs to use the correct nixpkgs version so all the systems line up + let + lib = pkgs.lib; + platform = lib.systems.elaborate { inherit system; }; + # Can't just default to [] for platforms, since no meta.platforms + # means "all platforms" not "no platforms" + in + drv: + if drv ? meta && drv.meta ? platforms then + lib.any (lib.meta.platformMatch platform) drv.meta.platforms + else true; + + # Hydra doesn't like these attributes hanging around in "jobsets": it thinks they're jobs! + stripAttrsForHydra = filterAttrsOnlyRecursive (n: _: n != "recurseForDerivations" && n != "dimension"); + + # Keep derivations and attrsets with 'recurseForDerivations'. This ensures that we match the + # derivations that Hercules will see, and prevents Hydra from trying to pick up all sorts of bad stuff + # (like attrsets that contain themselves!). + filterDerivations = filterAttrsOnlyRecursive (n: attrs: lib.isDerivation attrs || attrs.recurseForDerivations or false); + + # A version of 'filterAttrsRecursive' that doesn't recurse into derivations. This prevents us from going into an infinite + # loop with the 'out' attribute on derivations. + # TODO: Surely this shouldn't be necessary. I think normal 'filterAttrsRecursive' will effectively cause infinite loops + # if you keep derivations and your predicate forces the value of the attribute, as this then triggers a loop on the + # 'out' attribute. Weird. + filterAttrsOnlyRecursive = pred: set: + lib.listToAttrs ( + lib.concatMap + (name: + let v = set.${name}; in + if pred name v then [ + (lib.nameValuePair name ( + if builtins.isAttrs v && !lib.isDerivation v then filterAttrsOnlyRecursive pred v + else v + )) + ] else [ ] + ) + (builtins.attrNames set) + ); + + # Takes an array of systems and returns a `name: system` AttrSet + # filterSystems :: [ string ] -> AttrSet + filterSystems = systems: lib.filterAttrs (_: v: builtins.elem v systems) { + linux = "x86_64-linux"; + darwin = "x86_64-darwin"; + }; +} diff --git a/MetaLamp/nft-marketplace/nix/pkgs/default.nix b/MetaLamp/nft-marketplace/nix/pkgs/default.nix new file mode 100644 index 000000000..f007ae906 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/pkgs/default.nix @@ -0,0 +1,32 @@ +{ pkgs +, sources +, plutus +, haskell-nix +}: +let + gitignore-nix = pkgs.callPackage plutus."gitignore.nix" { }; + + compiler-nix-name = plutus.plutus-apps.haskell.compiler-nix-name; + + haskell = pkgs.callPackage ./haskell { + inherit gitignore-nix sources haskell-nix; + inherit compiler-nix-name; # Use the same GHC version as plutus + inherit (pkgs) libsodium-vrf; + }; + + hlint = plutus.plutus-apps.hlint; + + cabal-install = plutus.plutus-apps.cabal-install; + + fix-stylish-haskell = plutus.plutus-apps.fixStylishHaskell; + + stylish-haskell = plutus.plutus-apps.stylish-haskell; + + haskell-language-server = plutus.plutus-apps.haskell-language-server; + + cardano-repo-tool = plutus.plutus-apps.cardano-repo-tool; +in +{ + inherit haskell hlint cabal-install stylish-haskell fix-stylish-haskell haskell-language-server; + inherit cardano-repo-tool; +} \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/nix/pkgs/haskell/default.nix b/MetaLamp/nft-marketplace/nix/pkgs/haskell/default.nix new file mode 100644 index 000000000..aa36c8b87 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/pkgs/haskell/default.nix @@ -0,0 +1,36 @@ +{ lib +, haskell-nix +, gitignore-nix +, sources +, compiler-nix-name +, libsodium-vrf +}: +let + # The Hackage index-state from cabal.project + index-state = + let + parseIndexState = rawCabalProject: + let + indexState = lib.lists.concatLists ( + lib.lists.filter (l: l != null) + (map (l: builtins.match "^index-state: *(.*)" l) + (lib.splitString "\n" rawCabalProject))); + in + lib.lists.head (indexState ++ [ null ]); + in + parseIndexState (builtins.readFile ../../../cabal.project); + + # The haskell project created by haskell-nix.cabalProject' + project = import ./haskell.nix { + inherit lib haskell-nix compiler-nix-name gitignore-nix libsodium-vrf; + }; + + # All the packages defined by our project, including dependencies + packages = project.hsPkgs; + + # Just the packages in the project + projectPackages = haskell-nix.haskellLib.selectProjectPackages packages; +in +rec { + inherit project projectPackages packages; +} diff --git a/MetaLamp/nft-marketplace/nix/pkgs/haskell/haskell.nix b/MetaLamp/nft-marketplace/nix/pkgs/haskell/haskell.nix new file mode 100644 index 000000000..d6401f530 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/pkgs/haskell/haskell.nix @@ -0,0 +1,57 @@ +############################################################################ +# Builds Haskell packages with Haskell.nix +############################################################################ +{ haskell-nix +, gitignore-nix +, compiler-nix-name +, lib +, libsodium-vrf +}: + +let + project = haskell-nix.project { + # 'cleanGit' cleans a source directory based on the files known by git + src = haskell-nix.haskellLib.cleanGit { + name = "plutus-starter"; + src = ../../../.; + }; + + inherit compiler-nix-name; + + sha256map = { + "https://github.com/input-output-hk/plutus-apps.git"."v2021-11-22" = "10m0gmnakjnpnzyvjs3ksfpxgjcq3pdphr4gf8v7fjhr9fjbc45n"; + "https://github.com/Quid2/flat.git"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm"; + "https://github.com/input-output-hk/purescript-bridge.git"."366fc70b341e2633f3ad0158a577d52e1cd2b138" = "18j0rysfccbmfpbw2d1rsjkpd5h84alpsn6b5rwzdxw9h5vqi9m5"; + "https://github.com/input-output-hk/servant-purescript.git"."ebea59c7bdfc0338d83fca772b9a57e28560bcde" = "0gjcq4y61kwb4w70pnswn5dp23wd13dac8d9hz84j374cm1kshsn"; + "https://github.com/input-output-hk/cardano-base"."4ea7e2d927c9a7f78ddc69738409a5827ab66b98" = "0n0hxbr0l95cdc25jmmgs7apmmw17i91chhj5rzzv1k7f3iymf6d"; + "https://github.com/input-output-hk/cardano-crypto.git"."07397f0e50da97eaa0575d93bee7ac4b2b2576ec" = "06sdx5ndn2g722jhpicmg96vsrys89fl81k8290b3lr6b1b0w4m3"; + "https://github.com/input-output-hk/cardano-ledger-specs"."bf008ce028751cae9fb0b53c3bef20f07c06e333" = "0my3801w1vinc0kf5yh9lxl6saqxgwm6ccg0vvzi104pafcwwcqx"; + "https://github.com/input-output-hk/cardano-prelude"."fd773f7a58412131512b9f694ab95653ac430852" = "02jddik1yw0222wd6q0vv10f7y8rdgrlqaiy83ph002f9kjx7mh6"; + "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg"; + "https://github.com/input-output-hk/iohk-monitoring-framework"."46f994e216a1f8b36fe4669b47b2a7011b0e153c" = "1il8fx3misp3650ryj368b3x95ksz01zz3x0z9k00807j93d0ka0"; + "https://github.com/input-output-hk/optparse-applicative"."7497a29cb998721a9068d5725d49461f2bba0e7a" = "1gvsrg925vynwgqwplgjmp53vj953qyh3wbdf34pw21c8r47w35r"; + "https://github.com/input-output-hk/ouroboros-network"."1f4973f36f689d6da75b5d351fb124d66ef1057d" = "186056rvzdzy4jhvamjjbcmjyr94hs5hcyr8x6a0ch21hv5f014p"; + "https://github.com/input-output-hk/cardano-node.git"."b6ca519f97a0e795611a63174687e6bb70c9f752" = "0z5lpmqc98fwg3xzpzxkfslbxdjwfyyw8bn8yq0574sf4942vqdn"; + "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx"; + "https://github.com/input-output-hk/hedgehog-extras"."edf6945007177a638fbeb8802397f3a6f4e47c14" = "0wc7qzkc7j4ns2rz562h6qrx2f8xyq7yjcb7zidnj7f6j0pcd0i9"; + "https://github.com/input-output-hk/cardano-addresses"."d2f86caa085402a953920c6714a0de6a50b655ec" = "0p6jbnd7ky2yf7bwb1350k8880py8dgqg39k49q02a6ij4ld01ay"; + "https://github.com/input-output-hk/plutus"."3f089ccf0ca746b399c99afe51e063b0640af547" = "1nx8xmdgwmnsla4qg4k67f5md8vm3p1p9i25ndalrqdg40z90486"; + "https://github.com/j-mueller/cardano-wallet"."6be73ab852c0592713dfe78218856d4a8a0ee69e" = "0rx5hvmbdv5dwb4qq39vyhisj0v75j21jbiivn3s3q9za6m6x1p4"; + }; + + modules = [ + { + packages = { + # Broken due to haddock errors. Refer to https://github.com/input-output-hk/plutus/blob/master/nix/pkgs/haskell/haskell.nix + plutus-ledger.doHaddock = false; + plutus-use-cases.doHaddock = false; + + # See https://github.com/input-output-hk/iohk-nix/pull/488 + cardano-crypto-praos.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; + cardano-crypto-class.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; + }; + } + ]; + }; +in + project \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/nix/sources.json b/MetaLamp/nft-marketplace/nix/sources.json new file mode 100644 index 000000000..2d3e32c68 --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/sources.json @@ -0,0 +1,14 @@ +{ + "plutus-apps": { + "branch": "master", + "description": "The Plutus application platform", + "homepage": "", + "owner": "input-output-hk", + "repo": "plutus-apps", + "rev": "v2021-11-22", + "sha256": "10m0gmnakjnpnzyvjs3ksfpxgjcq3pdphr4gf8v7fjhr9fjbc45n", + "type": "tarball", + "url": "https://github.com/input-output-hk/plutus-apps/archive/v2021-11-22.tar.gz", + "url_template": "https://github.com///archive/.tar.gz" + } +} \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/nix/sources.nix b/MetaLamp/nft-marketplace/nix/sources.nix new file mode 100644 index 000000000..1938409dd --- /dev/null +++ b/MetaLamp/nft-marketplace/nix/sources.nix @@ -0,0 +1,174 @@ +# This file has been generated by Niv. + +let + + # + # The fetchers. fetch_ fetches specs of type . + # + + fetch_file = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; + + fetch_tarball = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; + + fetch_git = name: spec: + let + ref = + if spec ? ref then spec.ref else + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; + in + builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; + + fetch_local = spec: spec.path; + + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; + + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; + + # + # Various helpers + # + + # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 + sanitizeName = name: + ( + concatMapStrings (s: if builtins.isList s then "-" else s) + ( + builtins.split "[^[:alnum:]+._?=-]+" + ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) + ) + ); + + # The set of packages used when specs are fetched using non-builtins. + mkPkgs = sources: system: + let + sourcesNixpkgs = + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; + hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; + hasThisAsNixpkgsPath = == ./.; + in + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import {} + else + abort + '' + Please specify either (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + # The actual fetching function. + fetch = pkgs: name: spec: + + if ! builtins.hasAttr "type" spec then + abort "ERROR: niv spec ${name} does not have a 'type' attribute" + else if spec.type == "file" then fetch_file pkgs name spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec + else if spec.type == "git" then fetch_git name spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name + else + abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + + # Ports of functions for older nix versions + + # a Nix version of mapAttrs if the built-in doesn't exist + mapAttrs = builtins.mapAttrs or ( + f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) + ); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatMapStrings = f: list: concatStrings (map f list); + concatStrings = builtins.concatStringsSep ""; + + # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 + optionalAttrs = cond: as: if cond then as else {}; + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) + else + fetchurl attrs; + + # Create the final "sources" from the config + mkSources = config: + mapAttrs ( + name: spec: + if builtins.hasAttr "outPath" spec + then abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = replace name (fetch config.pkgs name spec); } + ) config.sources; + + # The "config" used by the fetchers + mkConfig = + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) + , system ? builtins.currentSystem + , pkgs ? mkPkgs sources system + }: rec { + # The sources, i.e. the attribute set of spec name to spec + inherit sources; + + # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers + inherit pkgs; + }; + +in +mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/MetaLamp/nft-marketplace/pab-app/Main.hs b/MetaLamp/nft-marketplace/pab-app/Main.hs new file mode 100644 index 000000000..2691a3c49 --- /dev/null +++ b/MetaLamp/nft-marketplace/pab-app/Main.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeApplications #-} + +import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin +import Plutus.PAB.MarketplaceContracts (MarketplaceContracts) +import Plutus.PAB.Run (runWith) + +main :: IO () +main = do + runWith (Builtin.handleBuiltin @MarketplaceContracts) diff --git a/MetaLamp/nft-marketplace/pab-demo/Main.hs b/MetaLamp/nft-marketplace/pab-demo/Main.hs new file mode 100644 index 000000000..2cbe5106a --- /dev/null +++ b/MetaLamp/nft-marketplace/pab-demo/Main.hs @@ -0,0 +1,4 @@ +import Plutus.PAB.Simulation (startMpServer) + +main :: IO () +main = startMpServer diff --git a/MetaLamp/nft-marketplace/pab-simulation/Main.hs b/MetaLamp/nft-marketplace/pab-simulation/Main.hs new file mode 100644 index 000000000..45d5a05e1 --- /dev/null +++ b/MetaLamp/nft-marketplace/pab-simulation/Main.hs @@ -0,0 +1,4 @@ +import Plutus.PAB.Simulation (runNftMarketplace) + +main :: IO () +main = runNftMarketplace diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal new file mode 100644 index 000000000..9c36bfff9 --- /dev/null +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -0,0 +1,212 @@ +cabal-version: 2.4 +name: plutus-starter +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +license: Apache-2.0 +license-files: LICENSE +author: Your name +maintainer: Your email + +-- A copyright notice. +-- copyright: +-- category: +-- extra-source-files: CHANGELOG.md + +flag defer-plugin-errors + description: + Defer errors from the plugin, useful for things like Haddock that can't handle it. + default: False + manual: True + +common lang + default-language: Haskell2010 + ghc-options: + -Wall -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -rtsopts + -- See Plutus Tx readme + -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + if flag(defer-plugin-errors) + ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors + +library + import: lang + exposed-modules: + Ext.Plutus.Ledger.Index + Ext.Plutus.Ledger.Time + Ext.Plutus.Ledger.Value + Ext.Plutus.PAB.Webserver.Server + Plutus.Abstract.ContractResponse + Plutus.Abstract.Percentage + Plutus.Abstract.PercentageInterface + Plutus.Abstract.RemoteData + Plutus.Contracts.NftMarketplace.Endpoints + Plutus.Contracts.NftMarketplace.OffChain.ID + Plutus.Contracts.NftMarketplace.OffChain.Info + Plutus.Contracts.NftMarketplace.OffChain.Owner + Plutus.Contracts.NftMarketplace.OffChain.Serialization + Plutus.Contracts.NftMarketplace.OffChain.User + Plutus.Contracts.NftMarketplace.OnChain.Core + Plutus.Contracts.NftMarketplace.OnChain.Core.ID + Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace + Plutus.Contracts.NftMarketplace.OnChain.Core.NFT + Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine + Plutus.Contracts.Services.Auction + Plutus.Contracts.Services.Auction.Core + Plutus.Contracts.Services.Auction.Endpoints + Plutus.Contracts.Services.Auction.StateMachine + Plutus.Contracts.Services.Sale + Plutus.Contracts.Services.Sale.Core + Plutus.Contracts.Services.Sale.Endpoints + Plutus.Contracts.Services.Sale.StateMachine + Plutus.PAB.Simulation + Plutus.PAB.MarketplaceContracts + + build-depends: + QuickCheck, + aeson, + base >= 4.9 && < 5, + time, + avro, + bytestring, + containers, + cryptonite, + data-default, + freer-extras, + freer-simple, + lens, + memory, + prettyprinter, + semigroups, + servant-options, + servant-server, + servant-client, + http-client, + text, + wai-cors, + openapi3 -any, + -- Plutus: + playground-common, + plutus-contract, + plutus-ledger, + plutus-ledger-api, + plutus-pab, + plutus-tx, + plutus-tx-plugin, + plutus-use-cases + hs-source-dirs: src + +executable pab-demo + import: lang + main-is: Main.hs + hs-source-dirs: pab-demo + ghc-options: + -threaded + build-depends: + base >= 4.9 && < 5, + plutus-starter + +executable pab-app + import: lang + main-is: Main.hs + hs-source-dirs: pab-app + ghc-options: + -threaded + build-depends: + base >= 4.9 && < 5, + plutus-starter, + plutus-pab + +executable pab-simulation + import: lang + main-is: Main.hs + hs-source-dirs: pab-simulation + ghc-options: + -threaded + build-depends: + base >= 4.9 && < 5, + plutus-starter + +executable generate-typescript + import: lang + main-is: Main.hs + hs-source-dirs: generate-typescript + ghc-options: + -threaded + build-depends: + base >= 4.9 && < 5, + aeson-typescript, + servant-purescript -any, + mtl, + directory, + lens, + aeson, + bytestring, + -- Plutus: + plutus-starter, + plutus-pab, + plutus-contract, + plutus-ledger-api, + plutus-tx + +test-suite test + import: lang + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Abstract.Percentage + Abstract.RemoteDataSpec + Marketplace.Fixtures + Marketplace.Fixtures.CheckOptions + Marketplace.Fixtures.NFT + Marketplace.Fixtures.Script + Marketplace.Fixtures.Wallet + Marketplace.Spec.Auction + Marketplace.Spec.Bundles + Marketplace.Spec.CreateNft + Marketplace.Spec.Sale + Marketplace.Spec.Start + Utils + Utils.Data + Utils.Trace + build-depends: + plutus-contract -any, + plutus-core -any, + plutus-ledger -any, + plutus-ledger-api, + plutus-starter, + plutus-tx -any, + plutus-tx-plugin + build-depends: + QuickCheck -any, + aeson -any, + base >=4.9 && <5, + bytestring -any, + containers -any, + data-default -any, + foldl -any, + freer-extras -any, + freer-simple -any, + hedgehog -any, + lens -any, + mtl -any, + prettyprinter -any, + quickcheck-properties -any, + row-types -any, + streaming -any, + tasty -any, + tasty-golden -any, + tasty-hedgehog >=0.2.0.0, + tasty-hunit -any, + tasty-quickcheck -any, + text -any \ No newline at end of file diff --git a/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceArchitecture.png b/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceArchitecture.png new file mode 100644 index 000000000..8cb29dc35 Binary files /dev/null and b/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceArchitecture.png differ diff --git a/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceFlow.png b/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceFlow.png new file mode 100644 index 000000000..473fe3a4f Binary files /dev/null and b/MetaLamp/nft-marketplace/readme-src/NFTMarketplaceFlow.png differ diff --git a/MetaLamp/nft-marketplace/release.nix b/MetaLamp/nft-marketplace/release.nix new file mode 100644 index 000000000..d83bfbf3f --- /dev/null +++ b/MetaLamp/nft-marketplace/release.nix @@ -0,0 +1,52 @@ +# The content of this file was partially copied from the equivalent file in the plutus repository. +# It is used by IOHK's Hydra for CI (building the project, running the tests, etc.) +# +# Therefore, do not worry too much about the structure. +let + packages = import ./.; + + pkgs = packages.pkgs; + haskellNix = pkgs.haskell-nix; + + # Just the packages in the project + projectPackages = haskellNix.haskellLib.selectProjectPackages packages.project.hsPkgs; + + inherit (import ./nix/lib/ci.nix { inherit pkgs; }) dimension filterAttrsOnlyRecursive filterDerivations stripAttrsForHydra derivationAggregate; + + # Collects haskell derivations and builds an attrset: + # + # { library = { ... } + # , tests = { ... } + # , benchmarks = { ... } + # , exes = { ... } + # , checks = { ... } + # } + # Where each attribute contains an attribute set + # with all haskell components of that type + mkHaskellDimension = pkgs: haskellProjects: + let + # retrieve all checks from a Haskell package + collectChecks = _: ps: pkgs.haskell-nix.haskellLib.collectChecks' ps; + # retrieve all components of a Haskell package + collectComponents = type: ps: pkgs.haskell-nix.haskellLib.collectComponents' type ps; + # Given a component type and the retrieve function, retrieve components from haskell packages + select = type: selector: (selector type) haskellProjects; + # { component-type : retriever-fn } + attrs = { + "library" = collectComponents; + "tests" = collectComponents; + "benchmarks" = collectComponents; + "exes" = collectComponents; + "checks" = collectChecks; + }; + in + dimension "Haskell component" attrs select; + + ciJobsets = stripAttrsForHydra (filterDerivations { + shell = (import ./shell.nix); + + build = pkgs.recurseIntoAttrs (mkHaskellDimension pkgs projectPackages); + }); +in + ciJobsets // { required = derivationAggregate "required-plutus-starter" ciJobsets; } + diff --git a/MetaLamp/nft-marketplace/shell.nix b/MetaLamp/nft-marketplace/shell.nix new file mode 100644 index 000000000..c054df226 --- /dev/null +++ b/MetaLamp/nft-marketplace/shell.nix @@ -0,0 +1,22 @@ +let + packages = import ./.; + inherit (packages) pkgs plutus-starter; + inherit (plutus-starter) haskell; + +in + haskell.project.shellFor { + withHoogle = false; + + nativeBuildInputs = with plutus-starter; [ + hlint + cabal-install + fix-stylish-haskell + haskell-language-server + stylish-haskell + pkgs.niv + cardano-repo-tool + pkgs.ghcid + # HACK: This shouldn't need to be here. + pkgs.lzma.dev + ]; + } diff --git a/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Index.hs b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Index.hs new file mode 100644 index 000000000..114834f90 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Index.hs @@ -0,0 +1,11 @@ +module Ext.Plutus.Ledger.Index where + +import Ledger.Index (minAdaTxOut) +import Plutus.V1.Ledger.Ada (Ada, fromValue, lovelaceValueOf, + toValue) +import Plutus.V1.Ledger.Value (Value) + +-- TODO: That should be configurable in future: +-- Read minUTxOValue from `testnet-shelley-genesis.json` cardano-node config +minAdaTxOutValue :: Value +minAdaTxOutValue = toValue minAdaTxOut diff --git a/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Time.hs b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Time.hs new file mode 100644 index 000000000..98f9f68b5 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Time.hs @@ -0,0 +1,21 @@ +module Ext.Plutus.Ledger.Time where + +import Data.Avro.Internal.Time (utcTimeToMillis) +import qualified Data.Time.Clock as Time +import Plutus.V1.Ledger.Time (DiffMilliSeconds (..), POSIXTime (..), + fromMilliSeconds) + +convertUtcToPOSIX :: Time.UTCTime -> POSIXTime +convertUtcToPOSIX = POSIXTime . utcTimeToMillis + +-- | 'beginningOfTime' corresponds to the Shelley launch date +-- (2020-07-29T21:44:51Z) which is 1596059091000 in POSIX time +-- (number of milliseconds since 1970-01-01T00:00:00Z). +-- It is a hardcoded setting for pab simulation in Plutus code. +beginningOfTime :: POSIXTime +beginningOfTime = POSIXTime 1596059091000 + +newtype Seconds = Seconds Integer deriving Show + +addToBeginningOfTime :: Seconds -> POSIXTime +addToBeginningOfTime (Seconds s) = beginningOfTime + fromMilliSeconds (DiffMilliSeconds $ s * 1000) diff --git a/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Value.hs b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Value.hs new file mode 100644 index 000000000..4acccdba2 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Ext/Plutus/Ledger/Value.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NumericUnderscores #-} +module Ext.Plutus.Ledger.Value where + +import Control.Lens (view) +import qualified Data.Map as Map +import Data.Text (Text) +import Ledger (Address, TxOut (txOutValue), TxOutRef, + TxOutTx (txOutTxOut), Value) +import Ledger.AddressMap (UtxoMap) +import Ledger.Tx (ChainIndexTxOut, ciTxOutValue, toTxOut) +import Plutus.Contract +import Plutus.V1.Ledger.Value (Value) + +type ChainIndexTxMap = Map.Map TxOutRef ChainIndexTxOut + +utxosValue :: Address -> Contract w s Text Value +utxosValue address = do + os <- map snd . Map.toList <$> utxosAt address + return $ mconcat [view ciTxOutValue o | o <- os] diff --git a/MetaLamp/nft-marketplace/src/Ext/Plutus/PAB/Webserver/Server.hs b/MetaLamp/nft-marketplace/src/Ext/Plutus/PAB/Webserver/Server.hs new file mode 100644 index 000000000..a04ec87bc --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Ext/Plutus/PAB/Webserver/Server.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Ext.Plutus.PAB.Webserver.Server where + +import Cardano.Wallet.Mock.Types (WalletInfo (..)) +import Control.Concurrent.Availability (Availability, + available, newToken) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.OpenApi.Schema as OpenApi +import Data.Proxy +import Ledger.Crypto (pubKeyHash) +import qualified Network.Wai.Middleware.Cors as Cors +import qualified Network.Wai.Middleware.Servant.Options as Cors +import qualified Plutus.PAB.Effects.Contract as Contract +import Plutus.PAB.Simulator (Simulation) +import qualified Plutus.PAB.Simulator as Simulator +import Plutus.PAB.Webserver.API (API, WSAPI, + WalletProxy) +import qualified Plutus.PAB.Webserver.Server as PAB +import Servant (Application, + Handler (Handler), Raw, + ServerT, err500, + errBody, hoistServer, + serve, + serveDirectoryFileServer, + (:<|>) ((:<|>))) +import qualified Servant + + +-- Note: this definition is only to provide options responses +-- WSAPI is websocket api which does not support options requests +type CombinedAPI t = + API (Contract.ContractDef t) Integer + +startServer :: forall t env. + ( FromJSON (Contract.ContractDef t) + , ToJSON (Contract.ContractDef t) + , Contract.PABContract t + , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t) + , OpenApi.ToSchema (Contract.ContractDef t) + ) + => Simulation t (Simulation t ()) +startServer = do + availability <- newToken + let mkWalletInfo = do + (wllt, pk) <- Simulator.addWallet + pure $ WalletInfo{wiWallet = wllt, wiPubKeyHash = pk} + snd <$> PAB.startServer' corsMiddlewares 9080 (Right mkWalletInfo) Nothing availability 30 + where + corsMiddlewares = + [ -- a custom CORS policy since 'simpleCors' doesn't support "content-type" header by default + let policy = Cors.simpleCorsResourcePolicy { Cors.corsRequestHeaders = [ "content-type" ] } + in Cors.cors (const $ Just policy) + -- this middleware handles preflight OPTIONS browser requests + , Cors.provideOptions (Proxy @(API (Contract.ContractDef t) Integer)) + ] diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs new file mode 100644 index 000000000..4d478e824 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Plutus.Abstract.ContractResponse where + +import qualified Control.Lens as Lens +import Control.Monad hiding (fmap) +import qualified Data.Aeson as J +import qualified Data.Map.Strict as Map +import Data.Monoid (Last (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, symbolVal) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Abstract.RemoteData (RemoteData (..)) +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) +import qualified Plutus.V1.Ledger.Address as Addr +import Plutus.V1.Ledger.Value as Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Monoid (..), + Semigroup (..), mconcat, + unless) +import Prelude (Monoid (..), Semigroup (..), + show, subtract) +import qualified Prelude + +type ContractResponse k e a = Last (ContractState k e a) + +data ContractState k e a = ContractState { + endpointName :: k, + response :: RemoteData e a +} + deriving (Prelude.Eq, Prelude.Show, Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +withContractResponse :: forall l a p r s. + (HasEndpoint l p s, FromJSON p) + => Proxy l + -> (a -> r) + -> (p -> Contract (ContractResponse Prelude.String Text r) s Text a) + -> Promise (ContractResponse Prelude.String Text r) s Void () +withContractResponse ep g c = do + let makeResponse = Last . Just . ContractState (symbolVal ep) + handleEndpoint @l $ \case + Left err -> tell . makeResponse . Failure $ err + Right p -> do + _ <- tell . makeResponse $ Loading + e <- runError $ errorHandler `handleError` c p + tell $ case e of + Left err -> makeResponse . Failure $ err + Right a -> makeResponse . Success . g $ a + +errorHandler :: Text -> Contract w s Text b +errorHandler e = do + logInfo @Text ("Error submiting the transaction: " <> e) + throwError e diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/Percentage.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/Percentage.hs new file mode 100644 index 000000000..c44dc2346 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/Percentage.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Plutus.Abstract.Percentage where +import qualified Data.Aeson as J +import qualified Data.OpenApi.Schema as OpenApi +import GHC.Generics (Generic) +import qualified PlutusTx +import Prelude hiding (Fractional) +import qualified Schema + +type Fractional = (Integer, Integer) + +newtype Percentage = + Percentage + {getPercentage :: Fractional} + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema, OpenApi.ToSchema) + +PlutusTx.makeLift ''Percentage +PlutusTx.unstableMakeIsData ''Percentage + +mkPercentage :: Fractional -> Maybe Percentage +mkPercentage percentage@(numerator, denominator) = + let roundedPercentage = abs $ numerator `div` denominator + in + if denominator /= 0 && 0 <= roundedPercentage && roundedPercentage <= 100 + then pure $ Percentage percentage + else Nothing + diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/PercentageInterface.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/PercentageInterface.hs new file mode 100644 index 000000000..e143aa1e9 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/PercentageInterface.hs @@ -0,0 +1,12 @@ +module Plutus.Abstract.PercentageInterface (calculatePercentageRounded) where +import qualified Data.Aeson as J +import GHC.Generics (Generic) +import qualified Plutus.Abstract.Percentage as Percentage +import PlutusTx.Prelude ((*)) +import PlutusTx.Ratio as Ratio +import Prelude hiding ((*)) + +{-# INLINABLE calculatePercentageRounded #-} +calculatePercentageRounded :: Percentage.Percentage -> Integer -> Integer +calculatePercentageRounded (Percentage.Percentage (numerator, denominator)) percentageBy = + Ratio.round $ (percentageBy % 100) * (numerator % denominator) diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs new file mode 100644 index 000000000..7934ae400 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Plutus.Abstract.RemoteData where + +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens +import qualified Data.Aeson as J +import GHC.Generics (Generic) +import Prelude hiding (maybe) +import qualified Test.QuickCheck as Q + +-- | A datatype representing fetched data. +-- | +-- | If you find yourself continually using `Maybe (Either e a)` to +-- | represent data loaded from an external source, or you have a +-- | habit of shuffling errors away to where they can be quietly +-- | ignored, consider using this. It makes it easier to represent the +-- | real state of a remote data fetch and handle it properly. +-- | +-- | For more on the motivation, take a look at the blog post +-- | [How Elm Slays A UI Antipattern](http://blog.jenkster.com/2016/06/how-elm-slays-a-ui-antipattern.html). +-- | This is a port of that original Elm module. +data RemoteData e a + = NotAsked + | Loading + | Failure e + | Success a + deriving stock (Generic, Eq, Functor, Show, Foldable, Traversable) + deriving anyclass (J.FromJSON, J.ToJSON) +-- TODO implement Applicative Monad Bifunctor MonadThrow MonadError Bifoldable Bitraversable + +Lens.makeClassyPrisms ''RemoteData + +instance Semigroup (RemoteData e a) where + NotAsked <> x = x + x <> NotAsked = x + x <> y = y + +instance Monoid (RemoteData e a) where + mempty = NotAsked + +instance (Q.Arbitrary e, Q.Arbitrary a) => Q.Arbitrary (RemoteData e a) where + arbitrary = do + err <- Q.arbitrary + res <- Q.arbitrary + Q.elements [ NotAsked + , Loading + , Failure err + , Success res] + +------------------------------------------------------------ + +-- | Convert a `RemoteData` to a `Maybe`. +toMaybe :: forall e a. RemoteData e a -> Maybe a +toMaybe (Success value) = Just value +toMaybe _ = Nothing + +-- | Convert a `Maybe` to `RemoteData`. +fromMaybe :: forall e a. Maybe a -> RemoteData e a +fromMaybe Nothing = NotAsked +fromMaybe (Just value) = Success value + +-- | Convert an `Either` to `RemoteData` +fromEither :: forall e a. Either e a -> RemoteData e a +fromEither (Left err) = Failure err +fromEither (Right value) = Success value + +-- | Takes a default value, a function, and a `RemoteData` value. If +-- | the data is `Success`, apply the function to the value, otherwise +-- | return the default. +-- | +-- | See also `withDefault`. +maybe :: forall e a b. b -> (a -> b) -> RemoteData e a -> b +maybe default' f (Success value) = f value +maybe default' f _ = default' + +-- | If the `RemoteData` has been successfully loaded, return that, +-- | otherwise return a default value. +withDefault :: forall e a. a -> RemoteData e a -> a +withDefault default' = maybe default' id + +------------------------------------------------------------ + +-- | Simple predicate. +isNotAsked :: forall e a. RemoteData e a -> Bool +isNotAsked = Lens.is _NotAsked + +-- | Simple predicate. +isLoading :: forall e a. RemoteData e a -> Bool +isLoading = Lens.is _Loading + +-- | Simple predicate. +isFailure :: forall e a. RemoteData e a -> Bool +isFailure = Lens.is _Failure + +-- | Simple predicate. +isSuccess :: forall e a. RemoteData e a -> Bool +isSuccess = Lens.is _Success diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/Endpoints.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/Endpoints.hs new file mode 100644 index 000000000..43af3c43b --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/Endpoints.hs @@ -0,0 +1,9 @@ +module Plutus.Contracts.NftMarketplace.Endpoints + ( module Export + ) where + +import Plutus.Contracts.NftMarketplace.OffChain.ID as Export +import Plutus.Contracts.NftMarketplace.OffChain.Info as Export +import Plutus.Contracts.NftMarketplace.OffChain.Owner as Export +import Plutus.Contracts.NftMarketplace.OffChain.Serialization as Export +import Plutus.Contracts.NftMarketplace.OffChain.User as Export diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/ID.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/ID.hs new file mode 100644 index 000000000..d9c40a17b --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/ID.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Plutus.Contracts.NftMarketplace.OffChain.ID where + +import Control.Monad hiding + (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Contract +import Plutus.Contracts.Currency as Currency +import Plutus.Contracts.NftMarketplace.OffChain.Serialization (deserializeByteString) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core +import Plutus.Contracts.NftMarketplace.OnChain.Core.ID (InternalId (..)) +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema +import Text.Printf (printf) +data UserItemId = UserNftId Text | UserBundleId [Text] + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +-- TODO remove ToSchema instances when constraint is removed from PAB +instance Schema.ToSchema UserItemId where + toSchema = Schema.FormSchemaUnsupported "TODO how to make these instances for sum types?" + +toInternalId :: UserItemId -> InternalId +toInternalId (UserNftId (deserializeByteString -> ipfsCid)) = NftInternalId + Core.InternalNftId { + Core.iniIpfsCidHash = sha2_256 ipfsCid, + Core.iniIpfsCid = ipfsCid + } +toInternalId (UserBundleId (fmap deserializeByteString -> cids)) = BundleInternalId + Core.InternalBundleId { + Core.ibiIpfsCids = AssocMap.fromList $ (\cid -> (sha2_256 cid, cid)) <$> cids, + Core.ibiBundleId = Core.calcBundleIdHash cids + } diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Info.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Info.hs new file mode 100644 index 000000000..ee4983532 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Info.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Plutus.Contracts.NftMarketplace.OffChain.Info where + +import Control.Lens (_2, _Left, + _Right, (^.), + (^?)) +import qualified Control.Lens as Lens +import Control.Monad hiding (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Ext.Plutus.Ledger.Value (ChainIndexTxMap, + utxosValue) +import GHC.Generics (Generic) +import qualified GHC.Generics as Haskell +import Ledger +import Ledger.Ada (fromValue, + getLovelace) +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Typed.Tx +import Ledger.Value +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.Percentage (Percentage) +import Plutus.Abstract.RemoteData (RemoteData) +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.Currency as Currency +import Plutus.Contracts.NftMarketplace.OffChain.ID +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core +import Plutus.Contracts.NftMarketplace.OnChain.Core.ID (InternalId (..)) +import qualified Plutus.Contracts.Services.Auction as Auction +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import Text.Printf (printf) + +-- | Gets current Marketplace store state +marketplaceStore :: Core.Marketplace -> Contract w s Text Core.MarketplaceDatum +marketplaceStore marketplace = do + let client = Core.marketplaceClient marketplace + mapError' (getOnChainState client) >>= getStateDatum + +data MarketplaceSettingsInfo = MarketplaceSettingsInfo { + msCreationFee :: Integer, + msSaleFee :: Percentage +} + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +marketplaceSettings :: Core.Marketplace -> Contract w s Text MarketplaceSettingsInfo +marketplaceSettings Core.Marketplace {..} = + pure MarketplaceSettingsInfo { + msCreationFee = getLovelace marketplaceNFTFee, + msSaleFee = marketplaceSaleFee + } + +getStateDatum :: + Maybe (OnChainState Core.MarketplaceDatum i, ChainIndexTxMap) -> Contract w s Text Core.MarketplaceDatum +getStateDatum = maybe (throwError "Marketplace output not found") (pure . tyTxOutData . ocsTxOut . fst) + +getNftEntry :: Core.MarketplaceDatum -> Core.InternalNftId -> Contract w s Text Core.NFT +getNftEntry nftStore (Core.InternalNftId ipfsCidHash ipfsCid) = + maybe (throwError "NFT has not been created") pure $ + AssocMap.lookup ipfsCidHash $ Core.mdSingletons nftStore + +getBundleEntry :: Core.MarketplaceDatum -> Core.InternalBundleId -> Contract w s Text Core.NftBundle +getBundleEntry nftStore (Core.InternalBundleId bundleId cids) = + maybe (throwError "Bundle has not been created") pure $ + AssocMap.lookup bundleId $ Core.mdBundles nftStore + +-- | Gets all UTxOs belonging to a user and concats them into one Value +fundsAt :: PubKeyHash -> Contract w s Text Value +fundsAt pkh = utxosValue $ pubKeyHashAddress pkh + +-- | Gets all UTxOs belonging to the Marketplace script and concats them into one Value +marketplaceFunds :: Core.Marketplace -> Contract w s Text Value +marketplaceFunds marketplace = utxosValue $ Core.marketplaceAddress marketplace + +-- | Gets current auction state for specified NFT +getAuctionState :: Core.Marketplace -> UserItemId -> Contract w s Text Auction.AuctionState +getAuctionState marketplace itemId = do + let internalId = toInternalId itemId + nftStore <- marketplaceStore marketplace + auction <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on auction") pure $ + Core.getAuctionFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on auction") pure $ + Core.getAuctionFromBundle bundleEntry + + auctionState <- do + st <- mapError (T.pack . Haskell.show) $ Auction.currentState auction + maybe (throwError "Auction state not found") pure st + + logInfo @Haskell.String $ printf "Returned auction state %s" (Haskell.show auctionState) + pure auctionState + +mapError' :: Contract w s SMContractError a -> Contract w s Text a +mapError' = mapError $ T.pack . Haskell.show + +type MarketplaceInfoSchema = + Endpoint "fundsAt" PubKeyHash + .\/ Endpoint "marketplaceFunds" () + .\/ Endpoint "marketplaceStore" () + .\/ Endpoint "marketplaceSettings" () + .\/ Endpoint "getAuctionState" UserItemId + +data InfoContractState = + FundsAt Value + | MarketplaceFunds Value + | MarketplaceStore Core.MarketplaceDatum + | MarketplaceSettings MarketplaceSettingsInfo + | AuctionState Auction.AuctionState + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +Lens.makeClassyPrisms ''InfoContractState + +infoEndpoints :: Core.Marketplace -> Promise (ContractResponse Haskell.String Text InfoContractState) MarketplaceInfoSchema Void () +infoEndpoints marketplace = + (withContractResponse (Proxy @"fundsAt") FundsAt fundsAt + `select` withContractResponse (Proxy @"marketplaceFunds") MarketplaceFunds (const $ marketplaceFunds marketplace) + `select` withContractResponse (Proxy @"marketplaceStore") MarketplaceStore (const $ marketplaceStore marketplace) + `select` withContractResponse (Proxy @"marketplaceSettings") MarketplaceSettings (const $ marketplaceSettings marketplace) + `select` withContractResponse (Proxy @"getAuctionState") AuctionState (getAuctionState marketplace)) <> infoEndpoints marketplace diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Owner.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Owner.hs new file mode 100644 index 000000000..07f61bd72 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Owner.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module Plutus.Contracts.NftMarketplace.OffChain.Owner where + +import qualified Control.Lens as Lens +import Control.Monad hiding (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Ext.Plutus.Ledger.Index (minAdaTxOutValue) +import qualified GHC.Generics as Haskell +import Ledger +import Ledger.Ada (Ada (..)) +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.Percentage (Fractional, + mkPercentage) +import Plutus.Abstract.RemoteData (RemoteData) +import Plutus.Contract +import Plutus.Contract.Request (ownPubKeyHash) +import Plutus.Contract.StateMachine +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core +import Plutus.V1.Ledger.Ada (lovelaceValueOf) +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema +import Text.Printf (printf) + +data StartMarketplaceParams = StartMarketplaceParams { + creationFee :: Integer, -- fee by minting and bundling + saleFee :: Fractional -- fee by sale and auction +} + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +-- | Starts the NFT Marketplace protocol: minting protocol NFT, creating empty nft storage +start :: StartMarketplaceParams -> Contract w s Text Core.Marketplace +start StartMarketplaceParams {..} = do + pkh <- ownPubKeyHash + saleFeePercentage <- maybe (throwError "Operator's fee value should be in [0, 100]") pure $ mkPercentage saleFee + let marketplace = Core.Marketplace pkh (Lovelace creationFee) saleFeePercentage + let client = Core.marketplaceClient marketplace + void $ mapError (T.pack . Haskell.show @SMContractError) $ runInitialise client (Core.MarketplaceDatum AssocMap.empty AssocMap.empty) minAdaTxOutValue + + logInfo @Haskell.String $ printf "started Marketplace %s at address %s" (Haskell.show marketplace) (Haskell.show $ Core.marketplaceAddress marketplace) + pure marketplace + +type MarketplaceOwnerSchema = + Endpoint "start" StartMarketplaceParams + +data OwnerContractState = Started Core.Marketplace + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +Lens.makeClassyPrisms ''OwnerContractState + +ownerEndpoints :: Promise (ContractResponse Haskell.String Text OwnerContractState) MarketplaceOwnerSchema Void () +ownerEndpoints = withContractResponse (Proxy @"start") Started (start) <> ownerEndpoints diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Serialization.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Serialization.hs new file mode 100644 index 000000000..c2d876f9f --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Serialization.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Plutus.Contracts.NftMarketplace.OffChain.Serialization where + +import qualified Data.Aeson as J +import qualified Data.Aeson.Types as J +import Data.Text (Text) +import qualified Data.Text.Encoding as T +import qualified GHC.Generics as Haskell +import qualified PlutusTx as PlutusTx +import PlutusTx.Prelude +import qualified Prelude as Haskell + +newtype PlutusBuiltinByteString = PlutusBuiltinByteString { getPlutusBuiltinByteString :: BuiltinByteString } + deriving (Haskell.Eq, Haskell.Show, Haskell.Generic) + +PlutusTx.unstableMakeIsData ''PlutusBuiltinByteString + +PlutusTx.makeLift ''PlutusBuiltinByteString + +instance J.ToJSON PlutusBuiltinByteString where + toJSON (PlutusBuiltinByteString s) = J.String (serializeByteString s) + +instance J.FromJSON PlutusBuiltinByteString where + parseJSON (J.String s) = Haskell.pure . PlutusBuiltinByteString . deserializeByteString $ s + parseJSON invalid = J.prependFailure "parsing PlutusBuiltinByteString failed, " (J.typeMismatch "String" invalid) + +deserializePlutusBuiltinBS :: Text -> PlutusBuiltinByteString +deserializePlutusBuiltinBS = PlutusBuiltinByteString . deserializeByteString + +deserializeByteString :: Text -> BuiltinByteString +deserializeByteString = toBuiltin . T.encodeUtf8 + +serializeByteString :: BuiltinByteString -> Text +serializeByteString = T.decodeUtf8 . fromBuiltin + diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs new file mode 100644 index 000000000..4f4f3ce15 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.NftMarketplace.OffChain.User where + +import Control.Lens (_2, + _Left, + _Right, + (^.), + (^?)) +import qualified Control.Lens as Lens +import Control.Monad hiding + (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Typed.Tx +import qualified Ledger.Value as V +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.RemoteData (RemoteData) +import Plutus.Contract +import Plutus.Contract.Request (ownPubKeyHash) +import Plutus.Contract.StateMachine +import Plutus.Contracts.Currency as Currency +import Plutus.Contracts.NftMarketplace.OffChain.ID (UserItemId (..), + toInternalId) +import Plutus.Contracts.NftMarketplace.OffChain.Info +import Plutus.Contracts.NftMarketplace.OffChain.Serialization (deserializeByteString, + deserializePlutusBuiltinBS) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core +import Plutus.Contracts.NftMarketplace.OnChain.Core.ID (InternalId (..)) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core.ID as Core +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace as Marketplace +import qualified Plutus.Contracts.Services.Auction as Auction +import qualified Plutus.Contracts.Services.Sale as Sale +import Plutus.V1.Ledger.Time (DiffMilliSeconds (..), + POSIXTime (..), + fromMilliSeconds) +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema +import Text.Printf (printf) + +data CreateNftParams = + CreateNftParams { + cnpIpfsCid :: Text, + cnpNftName :: Text, + cnpNftDescription :: Text, + cnpNftCategory :: [Text], + cnpRevealIssuer :: Bool + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''CreateNftParams + +-- | The user specifies which NFT to mint and add to marketplace store, +-- he gets it into his wallet and the corresponding store entry is created +createNft :: Core.Marketplace -> CreateNftParams -> Contract w s Text () +createNft marketplace CreateNftParams {..} = do + let ipfsCid = deserializeByteString cnpIpfsCid + let ipfsCidHash = sha2_256 ipfsCid + nftStore <- Core.mdSingletons <$> marketplaceStore marketplace + when (isJust $ AssocMap.lookup ipfsCidHash nftStore) $ throwError "Nft entry already exists" + + pkh <- ownPubKeyHash + let tokenName = V.TokenName ipfsCid + nft <- + mapError (T.pack . Haskell.show @Currency.CurrencyError) $ + Currency.mintContract pkh [(tokenName, 1)] + let client = Core.marketplaceClient marketplace + let nftEntry = Core.NftInfo + { niCurrency = Currency.currencySymbol nft + , niName = deserializePlutusBuiltinBS cnpNftName + , niDescription = deserializePlutusBuiltinBS cnpNftDescription + , niCategory = deserializePlutusBuiltinBS <$> cnpNftCategory + , niIssuer = if cnpRevealIssuer then Just pkh else Nothing + } + void $ mapError' $ runStep client $ Core.CreateNftRedeemer ipfsCidHash nftEntry + + logInfo @Haskell.String $ printf "Created NFT %s with store entry %s" (Haskell.show nft) (Haskell.show nftEntry) + pure () + +data OpenSaleParams = + OpenSaleParams { + ospItemId :: UserItemId, + ospSalePrice :: Sale.LovelacePrice + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''OpenSaleParams + +-- | The user opens sale for his NFT +openSale :: Core.Marketplace -> OpenSaleParams -> Contract w s Text () +openSale marketplace@Core.Marketplace{..} OpenSaleParams {..} = do + let internalId = toInternalId ospItemId + nftStore <- marketplaceStore marketplace + saleValue <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> + Core.nftValue ipfsCid <$> getNftEntry nftStore nftId + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> + Core.bundleValue cids <$> getBundleEntry nftStore bundleId + let openSaleParams = Sale.OpenSaleParams { + ospSalePrice = ospSalePrice, + ospSaleValue = saleValue, + ospSaleFee = Just $ Sale.SaleFee marketplaceOperator marketplaceSaleFee + } + sale <- Sale.openSale openSaleParams + + let client = Core.marketplaceClient marketplace + let lot = Core.SaleLotLink sale + void $ mapError' $ runStep client $ Core.mkPutLotRedeemer internalId lot + + logInfo @Haskell.String $ printf "Created NFT sale %s" (Haskell.show sale) + pure () + +data CloseLotParams = + CloseLotParams { + clpItemId :: UserItemId + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''CloseLotParams + +-- | The user buys specified NFT lot +buyItem :: Core.Marketplace -> CloseLotParams -> Contract w s Text () +buyItem marketplace CloseLotParams {..} = do + let internalId = toInternalId clpItemId + nftStore <- marketplaceStore marketplace + sale <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on sale") pure $ + Core.getSaleFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on sale") pure $ + Core.getSaleFromBundle bundleEntry + + _ <- Sale.buyLot sale + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.mkRemoveLotRedeemer internalId + + logInfo @Haskell.String $ printf "Bought lot from sale %s" (Haskell.show sale) + pure () + +-- | The user closes NFT sale and receives his token back +closeSale :: Core.Marketplace -> CloseLotParams -> Contract w s Text () +closeSale marketplace CloseLotParams {..} = do + let internalId = toInternalId clpItemId + nftStore <- marketplaceStore marketplace + sale <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on sale") pure $ + Core.getSaleFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on sale") pure $ + Core.getSaleFromBundle bundleEntry + + _ <- Sale.redeemLot sale + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.mkRemoveLotRedeemer internalId + + logInfo @Haskell.String $ printf "Closed lot sale %s" (Haskell.show sale) + pure () + +data StartAnAuctionParams = + StartAnAuctionParams { + saapItemId :: UserItemId, + saapInitialPrice :: Ada, + saapEndTime :: POSIXTime + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''StartAnAuctionParams + +-- | The user starts an auction for specified NFT +startAnAuction :: Core.Marketplace -> StartAnAuctionParams -> Contract w s Text () +startAnAuction marketplace@Core.Marketplace{..} StartAnAuctionParams {..} = do + let internalId = toInternalId saapItemId + nftStore <- marketplaceStore marketplace + auctionValue <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> + Core.nftValue ipfsCid <$> getNftEntry nftStore nftId + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> + Core.bundleValue cids <$> getBundleEntry nftStore bundleId + + currTime <- currentTime + when (saapEndTime < currTime) $ throwError "Auction end time is from the past" + + self <- ownPubKeyHash + let startAuctionParams = Auction.StartAuctionParams { + sapOwner = self, + sapAsset = auctionValue, + sapInitialPrice = saapInitialPrice, + sapEndTime = saapEndTime, + sapAuctionFee = Just $ Auction.AuctionFee marketplaceOperator marketplaceSaleFee + } + auction <- mapError (T.pack . Haskell.show) $ Auction.startAuction startAuctionParams + + let client = Core.marketplaceClient marketplace + let lot = Core.AuctionLotLink auction + void $ mapError' $ runStep client $ Core.mkPutLotRedeemer internalId lot + + logInfo @Haskell.String $ printf "Started an auction %s" (Haskell.show auction) + pure () + +-- | The user completes the auction for specified NFT +completeAnAuction :: Core.Marketplace -> CloseLotParams -> Contract w s Text () +completeAnAuction marketplace CloseLotParams {..} = do + let internalId = toInternalId clpItemId + nftStore <- marketplaceStore marketplace + auction <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on auction") pure $ + Core.getAuctionFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on auction") pure $ + Core.getAuctionFromBundle bundleEntry + _ <- mapError (T.pack . Haskell.show) $ Auction.payoutAuction auction + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.mkRemoveLotRedeemer internalId + + logInfo @Haskell.String $ printf "Completed an auction %s" (Haskell.show auction) + pure () + +data BidOnAuctionParams = + BidOnAuctionParams { + boapItemId :: UserItemId, + boapBid :: Ada + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''BidOnAuctionParams + +-- | The user submits a bid on the auction for specified NFT +bidOnAuction :: Core.Marketplace -> BidOnAuctionParams -> Contract w s Text () +bidOnAuction marketplace BidOnAuctionParams {..} = do + let internalId = toInternalId boapItemId + nftStore <- marketplaceStore marketplace + auction <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on auction") pure $ + Core.getAuctionFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on auction") pure $ + Core.getAuctionFromBundle bundleEntry + + currTime <- currentTime + when (currTime > (Auction.aEndTime auction)) $ throwError "Auction has expired." + + _ <- mapError (T.pack . Haskell.show) $ Auction.submitBid auction boapBid + + logInfo @Haskell.String $ printf "Submitted bid for auction %s" (Haskell.show auction) + pure () + +data BundleUpParams = + BundleUpParams { + bupIpfsCids :: [Text], + bupName :: Text, + bupDescription :: Text, + bupCategory :: [Text] + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''BundleUpParams + +-- | The user cancel the auction for specified NFT +cancelAnAuction :: Core.Marketplace -> CloseLotParams -> Contract w s Text () +cancelAnAuction marketplace CloseLotParams {..} = do + let internalId = toInternalId clpItemId + nftStore <- marketplaceStore marketplace + auction <- case internalId of + NftInternalId nftId@(Core.InternalNftId ipfsCidHash ipfsCid) -> do + nftEntry <- getNftEntry nftStore nftId + maybe (throwError "NFT has not been put on auction") pure $ + Core.getAuctionFromNFT nftEntry + BundleInternalId bundleId@(Core.InternalBundleId bundleHash cids) -> do + bundleEntry <- getBundleEntry nftStore bundleId + maybe (throwError "Bundle has not been put on auction") pure $ + Core.getAuctionFromBundle bundleEntry + currTime <- currentTime + + when (currTime > Auction.aEndTime auction) $ throwError "Auction time is over, can't cancel" + + _ <- mapError (T.pack . Haskell.show) $ Auction.cancelAuction auction + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.mkRemoveLotRedeemer internalId + + logInfo @Haskell.String $ printf "Canceled an auction %s" (Haskell.show auction) + pure () + +-- | The user creates a bundle from specified NFTs +bundleUp :: forall w s. Core.Marketplace -> BundleUpParams -> Contract w s Text () +bundleUp marketplace BundleUpParams {..} = do + let ipfsCids = deserializeByteString <$> bupIpfsCids + let bundleId = Core.calcBundleIdHash ipfsCids + bundles <- Core.mdBundles <$> marketplaceStore marketplace + when (isJust $ AssocMap.lookup bundleId bundles) $ throwError "Bundle entry already exists" + let nftIds = sha2_256 <$> ipfsCids + let bundleInfo = Core.BundleInfo + { biName = deserializePlutusBuiltinBS bupName + , biDescription = deserializePlutusBuiltinBS bupDescription + , biCategory = deserializePlutusBuiltinBS <$> bupCategory + } + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.BundleUpRedeemer nftIds bundleId bundleInfo + + logInfo @Haskell.String $ printf "Created a bundle %s" (Haskell.show bundleInfo) + pure () + +data UnbundleParams = + UnbundleParams { + upIpfsCids :: [Text] + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +Lens.makeClassy_ ''UnbundleParams + +-- | The user unbundles specified NFTs +unbundle :: Core.Marketplace -> UnbundleParams -> Contract w s Text () +unbundle marketplace UnbundleParams {..} = do + let bundleId = Core.calcBundleIdHash $ fmap deserializeByteString upIpfsCids + bundles <- Core.mdBundles <$> marketplaceStore marketplace + when (isNothing $ AssocMap.lookup bundleId bundles) $ throwError "Bundle entry does not exist" + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.UnbundleRedeemer bundleId + + logInfo @Haskell.String $ printf "Removed bundle by id %s" (Haskell.show bundleId) + pure () + +balanceAt :: PubKeyHash -> AssetClass -> Contract w s Text Integer +balanceAt pkh asset = flip V.assetClassValueOf asset <$> fundsAt pkh + +ownPubKeyBalance :: Contract w s Text Value +ownPubKeyBalance = ownPubKeyHash >>= fundsAt + +type MarketplaceUserSchema = + Endpoint "createNft" CreateNftParams + .\/ Endpoint "openSale" OpenSaleParams + .\/ Endpoint "buyItem" CloseLotParams + .\/ Endpoint "closeSale" CloseLotParams + .\/ Endpoint "startAnAuction" StartAnAuctionParams + .\/ Endpoint "completeAnAuction" CloseLotParams + .\/ Endpoint "cancelAnAuction" CloseLotParams + .\/ Endpoint "bidOnAuction" BidOnAuctionParams + .\/ Endpoint "bundleUp" BundleUpParams + .\/ Endpoint "unbundle" UnbundleParams + .\/ Endpoint "ownPubKey" () + .\/ Endpoint "ownPubKeyBalance" () + +data UserContractState = + NftCreated + | OpenedSale + | NftBought + | ClosedSale + | AuctionStarted + | AuctionComplete + | AuctionCanceled + | BidSubmitted + | Bundled + | Unbundled + | GetPubKey PubKeyHash + | GetPubKeyBalance Value + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +Lens.makeClassyPrisms ''UserContractState + +userEndpoints :: Core.Marketplace -> Promise (ContractResponse Haskell.String Text UserContractState) MarketplaceUserSchema Void () +userEndpoints marketplace = + (withContractResponse (Proxy @"createNft") (const NftCreated) (createNft marketplace) + `select` withContractResponse (Proxy @"openSale") (const OpenedSale) (openSale marketplace) + `select` withContractResponse (Proxy @"buyItem") (const NftBought) (buyItem marketplace) + `select` withContractResponse (Proxy @"closeSale") (const ClosedSale) (closeSale marketplace) + `select` withContractResponse (Proxy @"startAnAuction") (const AuctionStarted) (startAnAuction marketplace) + `select` withContractResponse (Proxy @"completeAnAuction") (const AuctionComplete) (completeAnAuction marketplace) + `select` withContractResponse (Proxy @"cancelAnAuction") (const AuctionCanceled) (cancelAnAuction marketplace) + `select` withContractResponse (Proxy @"bidOnAuction") (const BidSubmitted) (bidOnAuction marketplace) + `select` withContractResponse (Proxy @"bundleUp") (const Bundled) (bundleUp marketplace) + `select` withContractResponse (Proxy @"unbundle") (const Unbundled) (unbundle marketplace) + `select` withContractResponse (Proxy @"ownPubKey") GetPubKey (const ownPubKeyHash) + `select` withContractResponse (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance)) <> userEndpoints marketplace diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core.hs new file mode 100644 index 000000000..bcb21392c --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Plutus.Contracts.NftMarketplace.OnChain.Core + ( module Export + , module Plutus.Contracts.NftMarketplace.OnChain.Core + ) where + +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.NftMarketplace.OnChain.Core.ID as Export +import Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace as Export +import Plutus.Contracts.NftMarketplace.OnChain.Core.NFT as Export +import Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine as Export +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell + +marketplaceValidator :: Marketplace -> Validator +marketplaceValidator = Scripts.validatorScript . marketplaceInst + +marketplaceAddress :: Marketplace -> Ledger.Address +marketplaceAddress = scriptAddress . marketplaceValidator diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/ID.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/ID.hs new file mode 100644 index 000000000..f16a02f99 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/ID.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.NftMarketplace.OnChain.Core.ID where + +import Control.Lens ((&), (.~), + (?~), (^.)) +import qualified Control.Lens as Lens +import qualified Crypto.Hash as Hash +import qualified Data.Aeson as J +import qualified Data.ByteArray as BA +import qualified Data.List as HL +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import qualified Ledger.Value as V +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.NftMarketplace.OnChain.Core.NFT +import qualified Plutus.Contracts.Services.Auction as Auction +import qualified Plutus.Contracts.Services.Sale as Sale +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell + +data InternalNftId = InternalNftId { + iniIpfsCidHash :: !IpfsCidHash, + iniIpfsCid :: !IpfsCid +} + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''InternalNftId + +PlutusTx.makeLift ''InternalNftId + +data InternalBundleId = InternalBundleId { + ibiBundleId :: !BundleId, + ibiIpfsCids :: !(AssocMap.Map IpfsCidHash IpfsCid) +} + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''InternalBundleId + +PlutusTx.makeLift ''InternalBundleId + +data InternalId = + NftInternalId InternalNftId + | BundleInternalId InternalBundleId + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''InternalId + +PlutusTx.makeLift ''InternalId diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/Marketplace.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/Marketplace.hs new file mode 100644 index 000000000..0acdf01aa --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/Marketplace.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace where +import qualified Data.Aeson as J +import qualified Data.OpenApi.Schema as OpenApi +import GHC.Generics (Generic) +import Ledger +import Plutus.Abstract.Percentage (Percentage) +import qualified PlutusTx +import Prelude + +data Marketplace = + Marketplace + { marketplaceOperator :: PubKeyHash, + marketplaceNFTFee :: Ada, -- fixed fee by minting and bundling + marketplaceSaleFee :: Percentage -- percentage by selling on the Sale or Auction + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (J.ToJSON, J.FromJSON, OpenApi.ToSchema) + +PlutusTx.makeLift ''Marketplace +PlutusTx.unstableMakeIsData ''Marketplace diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/NFT.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/NFT.hs new file mode 100644 index 000000000..9ea2ef0dd --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/NFT.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.NftMarketplace.OnChain.Core.NFT where + +import Control.Lens (_2, + (&), + (.~), + (?~), + (^.), + (^?)) +import qualified Control.Lens as Lens +import Control.Monad (join) +import qualified Crypto.Hash as Hash +import qualified Data.Aeson as J +import qualified Data.ByteArray as BA +import qualified Data.List as HL +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import qualified Ledger.Value as V +import Plutus.Abstract.Percentage (Percentage) +import Plutus.Contract +import Plutus.Contract.StateMachine +import qualified Plutus.Contract.StateMachine as SM +import Plutus.Contracts.NftMarketplace.OffChain.Serialization (PlutusBuiltinByteString (..)) +import Plutus.Contracts.Services.Auction.Core (Auction (..), + AuctionFee) +import qualified Plutus.Contracts.Services.Auction.Core as Auction +import qualified Plutus.Contracts.Services.Sale as Sale +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell + +-- Category = [BuiltinByteString] +-- 1. acts as a list of category with nested subcategories +-- 2. acts as a list of tags +type IpfsCid = BuiltinByteString +type IpfsCidHash = BuiltinByteString +type Category = [PlutusBuiltinByteString] +type BundleId = BuiltinByteString + +data LotLink = + SaleLotLink Sale.Sale + | AuctionLotLink Auction.Auction + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''LotLink + +PlutusTx.makeLift ''LotLink + +Lens.makePrisms ''LotLink + +getLotValue :: LotLink -> V.Value +getLotValue (SaleLotLink sale) = Sale.saleValue sale +getLotValue (AuctionLotLink auction) = Auction.aAsset auction + +data NftInfo = + NftInfo + { niCurrency :: !CurrencySymbol + , niName :: !PlutusBuiltinByteString + , niDescription :: !PlutusBuiltinByteString + , niCategory :: !Category + , niIssuer :: !(Maybe PubKeyHash) + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''NftInfo + +PlutusTx.makeLift ''NftInfo + +Lens.makeClassy_ ''NftInfo + +data NFT = + NFT + { nftRecord :: !NftInfo + , nftLot :: !(Maybe (IpfsCid, LotLink)) + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''NFT + +PlutusTx.makeLift ''NFT + +Lens.makeClassy_ ''NFT + +getAuctionFromNFT :: NFT -> Maybe Auction.Auction +getAuctionFromNFT nft = nft ^. _nftLot ^? traverse . _2 . _AuctionLotLink + +getSaleFromNFT :: NFT -> Maybe Sale.Sale +getSaleFromNFT nft = nft ^. _nftLot ^? traverse . _2 . _SaleLotLink + +data Bundle + = NoLot !(AssocMap.Map IpfsCidHash NftInfo) + | HasLot !(AssocMap.Map IpfsCidHash (IpfsCid, NftInfo)) !LotLink + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''Bundle + +PlutusTx.makeLift ''Bundle + +Lens.makeClassyPrisms ''Bundle + +data BundleInfo = + BundleInfo + { biName :: !PlutusBuiltinByteString + , biDescription :: !PlutusBuiltinByteString + , biCategory :: !Category + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''BundleInfo + +PlutusTx.makeLift ''BundleInfo + +Lens.makeClassy_ ''BundleInfo + +data NftBundle = + NftBundle + { nbRecord :: !BundleInfo + , nbTokens :: !Bundle + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''NftBundle + +PlutusTx.makeLift ''NftBundle + +Lens.makeClassy_ ''NftBundle + +getAuctionFromBundle :: NftBundle -> Maybe Auction.Auction +getAuctionFromBundle nftBundle = nftBundle ^. _nbTokens ^? _HasLot . _2 . _AuctionLotLink + +getSaleFromBundle :: NftBundle -> Maybe Sale.Sale +getSaleFromBundle nftBundle = nftBundle ^. _nbTokens ^? _HasLot . _2 . _SaleLotLink + +-- Calculates a hash of a list of ByteStrings, +-- the result does not depend on the order of ByteStrings inside a list +calcBundleIdHash :: [IpfsCid] -> BundleId +calcBundleIdHash = BA.convert . Hash.hashUpdates alg . HL.sort + where + alg = Hash.hashInit @Hash.SHA256 + +{-# INLINABLE makeBundle #-} +makeBundle :: AssocMap.Map IpfsCidHash NFT -> [IpfsCidHash] -> BundleInfo -> NftBundle +makeBundle singletons nftIds bundleInfo = + NftBundle + { nbRecord = bundleInfo + , nbTokens = NoLot $ foldr insert AssocMap.empty nftIds + } + where + insert nftId store = case AssocMap.lookup nftId singletons of + Just n -> AssocMap.insert nftId (nftRecord n) store + Nothing -> store + +{-# INLINABLE bundleValue #-} +bundleValue :: AssocMap.Map IpfsCidHash IpfsCid -> NftBundle -> Value +bundleValue cids bundle = case nbTokens bundle of + NoLot tokens -> foldMap getValueNoLot $ AssocMap.toList tokens + HasLot tokens _ -> foldMap getValueHasLot tokens + where + getValueHasLot :: (IpfsCid, NftInfo) -> Value + getValueHasLot (ipfsCid, nft) = V.singleton (niCurrency nft) (V.TokenName ipfsCid) 1 + + getValueNoLot :: (IpfsCidHash, NftInfo) -> Value + getValueNoLot (ipfsCidHash, nft) = case AssocMap.lookup ipfsCidHash cids of + Just ipfsCid -> V.singleton (niCurrency nft) (V.TokenName ipfsCid) 1 + Nothing -> mempty + +{-# INLINABLE hasLotBundle #-} +hasLotBundle :: NftBundle -> Bool +hasLotBundle bundle = case nbTokens bundle of + HasLot _ _ -> True + _ -> False + +{-# INLINABLE nftValue #-} +nftValue :: IpfsCid -> NFT -> Value +nftValue ipfsCid nft = V.singleton (niCurrency $ nftRecord nft) (V.TokenName ipfsCid) 1 diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs new file mode 100644 index 000000000..4ea87485a --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine where + +import Control.Lens ((&), + (.~), + (?~), + (^.)) +import qualified Control.Lens as Lens +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import Ledger.Ada (toValue) +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import qualified Ledger.Value as V +import Plutus.Abstract.Percentage (Percentage) +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.NftMarketplace.OnChain.Core.ID +import Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace +import Plutus.Contracts.NftMarketplace.OnChain.Core.NFT +import qualified Plutus.Contracts.Services.Auction as Auction +import qualified Plutus.Contracts.Services.Sale as Sale +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell + +data RemoveLotRedeemerValue = + RemoveNftLotRedeemer IpfsCidHash + | RemoveBundleLotRedeemer BundleId + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''RemoveLotRedeemerValue + +PlutusTx.makeLift ''RemoveLotRedeemerValue + +data PutLotRedeemerValue = + PutNftLotRedeemer InternalNftId LotLink + | PutBundleLotRedeemer InternalBundleId LotLink + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''PutLotRedeemerValue + +PlutusTx.makeLift ''PutLotRedeemerValue + +mkPutLotRedeemer :: InternalId -> LotLink -> MarketplaceRedeemer +mkPutLotRedeemer (NftInternalId nId) lot = PutLotRedeemer $ PutNftLotRedeemer nId lot +mkPutLotRedeemer (BundleInternalId bId) lot = PutLotRedeemer $ PutBundleLotRedeemer bId lot + +data MarketplaceRedeemer + = CreateNftRedeemer IpfsCidHash NftInfo + | PutLotRedeemer PutLotRedeemerValue + | RemoveLotRedeemer RemoveLotRedeemerValue + | BundleUpRedeemer [IpfsCidHash] BundleId BundleInfo + | UnbundleRedeemer BundleId + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''MarketplaceRedeemer + +PlutusTx.makeLift ''MarketplaceRedeemer + +mkRemoveLotRedeemer :: InternalId -> MarketplaceRedeemer +mkRemoveLotRedeemer (NftInternalId nId) = RemoveLotRedeemer . RemoveNftLotRedeemer $ iniIpfsCidHash nId +mkRemoveLotRedeemer (BundleInternalId bId) = RemoveLotRedeemer . RemoveBundleLotRedeemer $ ibiBundleId bId + +data MarketplaceDatum = + MarketplaceDatum + { + mdSingletons :: AssocMap.Map IpfsCidHash NFT, + mdBundles :: AssocMap.Map BundleId NftBundle + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''MarketplaceDatum + +PlutusTx.makeLift ''MarketplaceDatum + +Lens.makeClassy_ ''MarketplaceDatum + +{-# INLINABLE insertNft #-} +insertNft :: IpfsCidHash + -> NFT -> MarketplaceDatum -> MarketplaceDatum +insertNft ipfsCidHash nftEntry store@MarketplaceDatum{..} = + store { mdSingletons = AssocMap.insert ipfsCidHash nftEntry mdSingletons } + +{-# INLINABLE insertBundle #-} +insertBundle :: BundleId + -> NftBundle -> MarketplaceDatum -> MarketplaceDatum +insertBundle bundleId bundle store@MarketplaceDatum{..} = + store { mdBundles = AssocMap.insert bundleId bundle mdBundles } + +{-# INLINABLE nftUnion #-} +nftUnion :: MarketplaceDatum -> AssocMap.Map IpfsCidHash NFT +nftUnion MarketplaceDatum{..} = foldr union mdSingletons $ fmap getNfts $ toList mdBundles + where + union = AssocMap.unionWith const + getNfts NftBundle{..} = case nbTokens of + NoLot val -> fmap (\info -> NFT info Nothing) val + HasLot val lot -> fmap (\(cid, info) -> NFT info (Just (cid, lot))) val + +{-# INLINABLE bundleUpDatum #-} +bundleUpDatum :: [IpfsCidHash] -> BundleId -> BundleInfo -> MarketplaceDatum -> MarketplaceDatum +bundleUpDatum nftIds bundleId bundleInfo MarketplaceDatum{..} = + MarketplaceDatum { mdSingletons = foldr AssocMap.delete mdSingletons nftIds + , mdBundles = AssocMap.insert bundleId (makeBundle mdSingletons nftIds bundleInfo) mdBundles + } + +{-# INLINABLE unbundleDatum #-} +unbundleDatum :: BundleId -> MarketplaceDatum -> MarketplaceDatum +unbundleDatum bundleId MarketplaceDatum{..} = + MarketplaceDatum { mdSingletons = foldr insert mdSingletons $ AssocMap.toList tokens + , mdBundles = AssocMap.delete bundleId mdBundles + } + where + bundle = fromMaybe (traceError "Bundle has not been created.") $ + AssocMap.lookup bundleId mdBundles + tokens = case nbTokens bundle of + NoLot ts -> ts + HasLot _ _ -> traceError "Could not unbundle: bundle has lot." + insert (nftId, record) = AssocMap.insert nftId $ NFT record Nothing + +{-# INLINABLE addLotToBundle #-} +addLotToBundle + :: AssocMap.Map IpfsCidHash IpfsCid -> LotLink -> NftBundle -> NftBundle +addLotToBundle cids lot NftBundle {..} = case nbTokens of + NoLot tokens -> NftBundle nbRecord $ HasLot (AssocMap.fromList $ fmap addCid $ AssocMap.toList tokens) lot + HasLot _ _ -> traceError "Could not add lot: bundle has one." + where + addCid :: (IpfsCidHash, NftInfo) -> (IpfsCidHash, (IpfsCid, NftInfo)) + addCid (nftId, entry) = (nftId, (fromMaybe (traceError "NFT IPFS Cid not provided") $ AssocMap.lookup nftId cids, entry)) + +{-# INLINABLE removeLotFromBundle #-} +removeLotFromBundle :: NftBundle -> NftBundle +removeLotFromBundle NftBundle {..} = NftBundle nbRecord $ NoLot $ snd <$> tokens + where + tokens = case nbTokens of + HasLot tokens _ -> tokens + NoLot _ -> traceError "Could not remove lot: bundle has none." + +{-# INLINABLE transition #-} +transition :: Marketplace -> State MarketplaceDatum -> MarketplaceRedeemer -> Maybe (TxConstraints Void Void, State MarketplaceDatum) +transition marketplace@Marketplace{..} state redeemer = case redeemer of + CreateNftRedeemer ipfsCidHash nftEntry + -> Just ( mustBeSignedByIssuer nftEntry <> + Constraints.mustPayToPubKey marketplaceOperator (toValue marketplaceNFTFee) + , State (insertNft ipfsCidHash (NFT nftEntry Nothing) nftStore) currStateValue + ) + PutLotRedeemer (PutNftLotRedeemer (InternalNftId ipfsCidHash ipfsCid) lot) + -> let newEntry = maybe (traceError "NFT has not been created.") (_nftLot ?~ (ipfsCid, lot)) $ + AssocMap.lookup ipfsCidHash $ mdSingletons nftStore + in Just ( mempty + , State (insertNft ipfsCidHash newEntry nftStore) currStateValue + ) + PutLotRedeemer (PutBundleLotRedeemer (InternalBundleId bundleId cids) lot) + -> let newEntry = maybe (traceError "Bundle has not been created.") (addLotToBundle cids lot) $ + AssocMap.lookup bundleId $ mdBundles nftStore + in Just ( mempty + , State (insertBundle bundleId newEntry nftStore) currStateValue + ) + RemoveLotRedeemer (RemoveNftLotRedeemer ipfsCidHash) + -> let newEntry = maybe (traceError "NFT has not been created.") (_nftLot .~ Nothing) $ + AssocMap.lookup ipfsCidHash $ mdSingletons nftStore + in Just ( mempty + , State (insertNft ipfsCidHash newEntry nftStore) currStateValue + ) + RemoveLotRedeemer (RemoveBundleLotRedeemer bundleId) + -> let newEntry = maybe (traceError "NFT has not been created.") removeLotFromBundle $ + AssocMap.lookup bundleId $ mdBundles nftStore + in Just ( mempty + , State (insertBundle bundleId newEntry nftStore) currStateValue + ) + BundleUpRedeemer nftIds bundleId bundleInfo + -> Just ( Constraints.mustPayToPubKey marketplaceOperator (toValue marketplaceNFTFee) + , State (bundleUpDatum nftIds bundleId bundleInfo nftStore) currStateValue + ) + UnbundleRedeemer bundleId + -> Just ( mempty + , State (unbundleDatum bundleId nftStore) currStateValue + ) + _ -> trace "Invalid transition" Nothing + where + nftStore :: MarketplaceDatum + nftStore = stateData state + + currStateValue = stateValue state + + mustBeSignedByIssuer entry = case niIssuer entry of + Just pkh -> Constraints.mustBeSignedBy pkh + Nothing -> mempty + +{-# INLINABLE stateTransitionCheck #-} +stateTransitionCheck :: MarketplaceDatum -> MarketplaceRedeemer -> ScriptContext -> Bool +stateTransitionCheck nftStore (CreateNftRedeemer ipfsCidHash nftEntry) ctx = + traceIfFalse "CreateNftRedeemer: " $ + traceIfFalse "NFT entry already exists" $ + isNothing $ AssocMap.lookup ipfsCidHash $ nftUnion nftStore +stateTransitionCheck MarketplaceDatum {..} (PutLotRedeemer (PutNftLotRedeemer (InternalNftId ipfsCidHash ipfsCid) lot)) ctx = + traceIfFalse "PutLotRedeemer: " $ + let nftEntry = fromMaybe (traceError "NFT has not been created") $ AssocMap.lookup ipfsCidHash mdSingletons + lotValue = getLotValue lot + hasBeenPutOnSale = lotValue == nftValue ipfsCid nftEntry + isValidHash = sha2_256 ipfsCid == ipfsCidHash + hasNoExistingLot = isNothing $ nftLot nftEntry + in traceIfFalse "NFT has not been put on sale or auction" hasBeenPutOnSale && + traceIfFalse "Invalid IPFS Cid Hash" isValidHash && + traceIfFalse "NFT already has a lot" hasNoExistingLot +stateTransitionCheck MarketplaceDatum {..} (PutLotRedeemer (PutBundleLotRedeemer (InternalBundleId bundleId cids) lot)) ctx = + traceIfFalse "PutLotRedeemer: " $ + let bundle = fromMaybe (traceError "Bundle has not been created") $ AssocMap.lookup bundleId mdBundles + lotValue = getLotValue lot + cidHashes = case nbTokens bundle of + NoLot tokens -> AssocMap.keys tokens + HasLot tokens _ -> AssocMap.keys tokens + allCidsProvided = all (isJust . (`AssocMap.lookup` cids)) cidHashes + hasBeenPutOnSale = bundleValue cids bundle == lotValue + isValidHash (ipfsCidHash, ipfsCid) = sha2_256 ipfsCid == ipfsCidHash + hasValidHashes = all isValidHash $ AssocMap.toList cids + hasNoExistingLot = not $ hasLotBundle bundle + in traceIfFalse "Bundle has not been put on sale or auction" hasBeenPutOnSale && + traceIfFalse "Not all IPFS Cids provided" allCidsProvided && + traceIfFalse "Invalid IPFS Cid Hash provided" hasValidHashes && + traceIfFalse "Bundle already has a lot" hasNoExistingLot +stateTransitionCheck MarketplaceDatum {..} (RemoveLotRedeemer (RemoveNftLotRedeemer ipfsCidHash)) ctx = + traceIfFalse "RemoveLotRedeemer: " $ + let nftEntry = fromMaybe (traceError "NFT has not been created") $ AssocMap.lookup ipfsCidHash mdSingletons + hasBeenPutOnSale = isJust $ nftLot nftEntry + in traceIfFalse "NFT has not been put on sale or auction" hasBeenPutOnSale +stateTransitionCheck MarketplaceDatum {..} (RemoveLotRedeemer (RemoveBundleLotRedeemer bundleId)) ctx = + traceIfFalse "RemoveLotRedeemer: " $ + let bundle = fromMaybe (traceError "Bundle has not been created") $ AssocMap.lookup bundleId mdBundles + hasLot = hasLotBundle bundle + in traceIfFalse "Bundle has not been put on sale or auction" hasLot +stateTransitionCheck MarketplaceDatum {..} (BundleUpRedeemer nftIds bundleId bundleInfo) ctx = + traceIfFalse "BundleUpRedeemer: " $ + let doesNotExist = isNothing $ AssocMap.lookup bundleId mdBundles + notEmty = not $ null nftIds + nfts = fromMaybe (traceError "NFT does not exist or is part of existing bundle") . (`AssocMap.lookup` mdSingletons) <$> nftIds + doesNotHaveLots = all (isNothing . nftLot) nfts + in traceIfFalse "Bundle entry already exists" doesNotExist && + traceIfFalse "Bundle is empty" notEmty && + traceIfFalse "One of NFTs has a lot" doesNotHaveLots +stateTransitionCheck MarketplaceDatum {..} (UnbundleRedeemer bundleId) ctx = + traceIfFalse "UnbundleRedeemer: " $ + let bundle = fromMaybe (traceError "Bundle does not exist") $ AssocMap.lookup bundleId mdBundles + doesNotHaveLot = not $ hasLotBundle bundle + in traceIfFalse "Bundle has a lot" doesNotHaveLot +stateTransitionCheck _ _ _ = traceError "Transition disallowed" + +{-# INLINABLE marketplaceStateMachine #-} +marketplaceStateMachine :: Marketplace -> StateMachine MarketplaceDatum MarketplaceRedeemer +marketplaceStateMachine marketplace = StateMachine + { smTransition = transition marketplace + , smFinal = const False + , smCheck = stateTransitionCheck + , smThreadToken = Nothing + } + +{-# INLINABLE mkMarketplaceValidator #-} +mkMarketplaceValidator :: Marketplace -> MarketplaceDatum -> MarketplaceRedeemer -> ScriptContext -> Bool +mkMarketplaceValidator marketplace = mkValidator $ marketplaceStateMachine marketplace + +type MarketplaceScript = StateMachine MarketplaceDatum MarketplaceRedeemer + +marketplaceInst :: Marketplace -> Scripts.TypedValidator MarketplaceScript +marketplaceInst marketplace = Scripts.mkTypedValidator @MarketplaceScript + ($$(PlutusTx.compile [|| mkMarketplaceValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode marketplace) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @MarketplaceDatum @MarketplaceRedeemer + +marketplaceClient :: Marketplace -> StateMachineClient MarketplaceDatum MarketplaceRedeemer +marketplaceClient marketplace = mkStateMachineClient $ StateMachineInstance (marketplaceStateMachine marketplace) (marketplaceInst marketplace) diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction.hs new file mode 100644 index 000000000..5035360cd --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction.hs @@ -0,0 +1,5 @@ +module Plutus.Contracts.Services.Auction (module Export) where + +import Plutus.Contracts.Services.Auction.Core as Export +import Plutus.Contracts.Services.Auction.Endpoints as Export +import Plutus.Contracts.Services.Auction.StateMachine as Export diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Core.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Core.hs new file mode 100644 index 000000000..3eb344df7 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Core.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Plutus.Contracts.Services.Auction.Core where + +import qualified Control.Lens as Lens +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Text as T +import GHC.Generics (Generic) +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import qualified Plutus.Abstract.Percentage as Percentage +import Plutus.Contract +import Plutus.Contract.StateMachine +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema + +data AuctionFee = + AuctionFee + { afAuctionOperator :: !PubKeyHash + , afAuctionFee :: !Percentage.Percentage + } + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''AuctionFee + +PlutusTx.makeLift ''AuctionFee + +Lens.makeClassy_ ''AuctionFee + +-- | Definition of an auction +data Auction + = Auction + { aProtocolToken :: !ThreadToken + , aOwner :: !PubKeyHash + , aAsset :: !Value + , aInitialPrice :: !Ada + , aEndTime :: !Ledger.POSIXTime + , aAuctionFee :: Maybe AuctionFee + } + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +PlutusTx.makeLift ''Auction + +PlutusTx.unstableMakeIsData ''Auction + +Lens.makeClassy_ ''Auction + +{-# INLINABLE getAuctionStateToken #-} +getAuctionStateToken :: Auction -> ThreadToken +getAuctionStateToken = aProtocolToken diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Endpoints.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Endpoints.hs new file mode 100644 index 000000000..710bc8ccf --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/Endpoints.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.Services.Auction.Endpoints where +import Control.Lens (makeClassyPrisms) +import Data.Aeson (FromJSON, + ToJSON) +import qualified Data.Aeson as J +import Data.Monoid (Last (..)) +import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) +import qualified Data.Text as T +import Ext.Plutus.Ledger.Index (minAdaTxOutValue) +import GHC.Generics (Generic) +import Ledger (Ada, + PubKeyHash, + Slot, Value) +import qualified Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import Ledger.Constraints.TxConstraints (TxConstraints) +import qualified Ledger.Interval as Interval +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Typed.Tx (TypedScriptTxOut (..)) +import Ledger.Value (AssetClass) +import qualified Plutus.Abstract.Percentage as Percentage +import qualified Plutus.Abstract.PercentageInterface as Percentage +import Plutus.Contract +import Plutus.Contract.Request (ownPubKeyHash) +import Plutus.Contract.StateMachine hiding + (mkValidator, + typedValidator) +import qualified Plutus.Contract.StateMachine as SM +import Plutus.Contract.Util (loopM) +import qualified Plutus.Contracts.Currency as Currency +import Plutus.Contracts.Services.Auction.Core +import Plutus.Contracts.Services.Auction.StateMachine +import qualified PlutusTx +import PlutusTx.Prelude +import qualified Prelude as Haskell +import qualified Schema + +data StartAuctionParams = StartAuctionParams { + sapOwner :: !PubKeyHash, + sapAsset :: !Value, + sapInitialPrice :: !Ada, + sapEndTime :: !Ledger.POSIXTime, + sapAuctionFee :: Maybe AuctionFee +} + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''StartAuctionParams +PlutusTx.makeLift ''StartAuctionParams + +-- | Client code for the seller +startAuction :: StartAuctionParams -> Contract w s AuctionError Auction +startAuction StartAuctionParams{..} = do + threadToken <- SM.getThreadToken + logInfo $ "Obtained thread token: " <> Haskell.show threadToken + let auction@Auction{..} = Auction { + aProtocolToken = threadToken, + aOwner = sapOwner, + aAsset = sapAsset, + aInitialPrice = sapInitialPrice, + aEndTime = sapEndTime, + aAuctionFee = sapAuctionFee + } + let inst = typedValidator auction + client = machineClient inst auction + + _ <- handleError + (\e -> do { logError (AuctionFailed e); throwError (StateMachineContractError e) }) + (SM.runInitialise client (initialState aOwner) (aAsset + minAdaTxOutValue)) + + logInfo $ AuctionStarted auction + pure auction + +-- | Client code for the seller +payoutAuction :: Auction -> Contract w s AuctionError () +payoutAuction auction = do + let inst = typedValidator auction + client = machineClient inst auction + + r <- SM.runStep client Payout + case r of + SM.TransitionFailure i -> logError (TransitionFailed i) >> throwError InvalidAuctionTransition + SM.TransitionSuccess (Finished h) -> logInfo $ AuctionEnded h + SM.TransitionSuccess s -> logWarn ("Unexpected state after Payout transition: " <> Haskell.show s) + +cancelAuction :: Auction -> Contract w s AuctionError () +cancelAuction auction = do + let inst = typedValidator auction + client = machineClient inst auction + r <- SM.runStep client Cancel + case r of + SM.TransitionFailure i -> logError (TransitionFailed i) >> throwError InvalidAuctionTransition + SM.TransitionSuccess Canceled -> logInfo $ AuctionCanceled + SM.TransitionSuccess s -> logWarn ("Unexpected state after Payout transition: " <> Haskell.show s) + +-- | Get the current state of the contract and log it. +currentState :: Auction -> Contract w s AuctionError (Maybe AuctionState) +currentState auction = mapError StateMachineContractError (SM.getOnChainState client) >>= \case + Just (SM.OnChainState{SM.ocsTxOut=TypedScriptTxOut{tyTxOutData= s}}, _) -> do + pure (Just s) + _ -> do + logWarn CurrentStateNotFound + pure Nothing + where + inst = typedValidator auction + client = machineClient inst auction + +submitBid :: Auction -> Ada -> Contract w s AuctionError ((Either T.Text ())) +submitBid auction ada = do + let inst = typedValidator auction + client = machineClient inst auction + self <- ownPubKeyHash + let bid = Bid{newBid = ada, newBidder = self} + result <- SM.runStep client bid + case result of + TransitionSuccess newState -> do + logInfo @Haskell.String $ "Bid submitted. New state is: " <> Haskell.show newState + pure $ Right () + _ -> do + logInfo @Haskell.String $ "Auction bid failed" + throwError InvalidAuctionTransition + pure $ Left "Auction bid failed" + +data AuctionLog = + AuctionStarted Auction + | AuctionFailed SM.SMContractError + | BidSubmitted HighestBid + | AuctionEnded HighestBid + | AuctionCanceled + | CurrentStateNotFound + | TransitionFailed (SM.InvalidTransition AuctionState AuctionInput) + deriving stock (Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +data AuctionError = + StateMachineContractError SM.SMContractError -- ^ State machine operation failed + | AuctionContractError ContractError -- ^ Endpoint, coin selection, etc. failed + | InvalidAuctionTransition + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +makeClassyPrisms ''AuctionError + +instance AsContractError AuctionError where + _ContractError = _AuctionContractError . _ContractError + +instance SM.AsSMContractError AuctionError where + _SMContractError = _StateMachineContractError . SM._SMContractError diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/StateMachine.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/StateMachine.hs new file mode 100644 index 000000000..a182a379c --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Auction/StateMachine.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +module Plutus.Contracts.Services.Auction.StateMachine where +import Control.Lens (makeClassyPrisms) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as J +import Data.Monoid (Last (..)) +import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) +import Ext.Plutus.Ledger.Index (minAdaTxOutValue) +import GHC.Generics (Generic) +import Ledger (Ada, PubKeyHash, Slot, + Value) +import qualified Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import Ledger.Constraints.TxConstraints (TxConstraints) +import qualified Ledger.Interval as Interval +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Typed.Tx (TypedScriptTxOut (..)) +import Ledger.Value (AssetClass) +import qualified Plutus.Abstract.Percentage as Percentage +import qualified Plutus.Abstract.PercentageInterface as Percentage +import Plutus.Contract +import Plutus.Contract.StateMachine hiding (mkValidator, + typedValidator) +import qualified Plutus.Contract.StateMachine as SM +import Plutus.Contract.Util (loopM) +import qualified Plutus.Contracts.Currency as Currency +import Plutus.Contracts.Services.Auction.Core +import Plutus.V1.Ledger.Time (POSIXTime (..)) +import qualified PlutusTx +import PlutusTx.Prelude +import qualified Prelude as Haskell +import qualified Schema + +data HighestBid = + HighestBid + { highestBid :: Ada + , highestBidder :: PubKeyHash + } + deriving stock (Haskell.Eq, Haskell.Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +PlutusTx.unstableMakeIsData ''HighestBid + +-- | The states of the auction +data AuctionState + = Ongoing HighestBid -- Bids can be submitted. + | Finished HighestBid -- The auction is finished + | Canceled + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (ToJSON, FromJSON) + +-- | Observable state of the auction app +data AuctionOutput = + AuctionOutput + { auctionState :: Last AuctionState + , auctionThreadToken :: Last SM.ThreadToken + } + deriving stock (Generic, Haskell.Show, Haskell.Eq) + deriving anyclass (ToJSON, FromJSON) + +deriving via (GenericSemigroupMonoid AuctionOutput) instance (Haskell.Semigroup AuctionOutput) +deriving via (GenericSemigroupMonoid AuctionOutput) instance (Haskell.Monoid AuctionOutput) + +auctionStateOut :: AuctionState -> AuctionOutput +auctionStateOut s = Haskell.mempty { auctionState = Last (Just s) } + +threadTokenOut :: SM.ThreadToken -> AuctionOutput +threadTokenOut t = Haskell.mempty { auctionThreadToken = Last (Just t) } + +-- | Initial 'AuctionState'. In the beginning the highest bid is 0 and the +-- highest bidder is seller of the asset. So if nobody submits +-- any bids, the seller gets the asset back after the auction has ended. +initialState :: PubKeyHash -> AuctionState +initialState self = Ongoing HighestBid{highestBid = 0, highestBidder = self} + +PlutusTx.unstableMakeIsData ''AuctionState + +-- | Transition between auction states +data AuctionInput + = Bid { newBid :: Ada, newBidder :: PubKeyHash } -- Increase the price + | Payout + | Cancel + deriving stock (Generic, Haskell.Show) + deriving anyclass (ToJSON, FromJSON) + +PlutusTx.unstableMakeIsData ''AuctionInput + +type AuctionMachine = StateMachine AuctionState AuctionInput + +type GetAdditionalConstraints = Auction -> State AuctionState -> TxConstraints Void Void + +auctionWithFeePayoutConstraints :: AuctionFee -> GetAdditionalConstraints +auctionWithFeePayoutConstraints AuctionFee{..} Auction{..} State {stateData = (Ongoing HighestBid{highestBidder, highestBid})} = + let highestBidInLovelace = Ada.getLovelace highestBid + saleProfit = highestBidInLovelace - fee + fee = Percentage.calculatePercentageRounded afAuctionFee highestBidInLovelace + in + Constraints.mustPayToPubKey aOwner (Ada.lovelaceValueOf saleProfit) <> + Constraints.mustPayToPubKey afAuctionOperator (Ada.lovelaceValueOf fee) +auctionWithFeePayoutConstraints _ _ _ = mempty + +auctionWithoutFeePayoutConstraints :: GetAdditionalConstraints +auctionWithoutFeePayoutConstraints Auction{..} State {stateData = (Ongoing HighestBid{highestBidder, highestBid})} = + Constraints.mustPayToPubKey aOwner (Ada.toValue highestBid) +auctionWithoutFeePayoutConstraints _ _ = mempty + + +{-# INLINABLE auctionTransition #-} +-- | The transitions of the auction state machine. +auctionTransition :: GetAdditionalConstraints -> Auction -> State AuctionState -> AuctionInput -> Maybe (TxConstraints Void Void, State AuctionState) +auctionTransition getAdditionalPayoutConstraints params@Auction{..} state@State{stateData=oldState} input = + case (oldState, input) of + + (Ongoing HighestBid{highestBid, highestBidder}, Bid{newBid, newBidder}) | (newBid >= aInitialPrice) && (newBid > highestBid) -> -- if the new bid is higher, + let constraints = + Constraints.mustPayToPubKey highestBidder (Ada.toValue highestBid) -- we pay back the previous highest bid + <> Constraints.mustValidateIn (Interval.to $ aEndTime - 1) -- but only if we haven't gone past 'aEndTime' + newState = + State + { stateData = Ongoing HighestBid{highestBid = newBid, highestBidder = newBidder} + , stateValue = aAsset <> Ada.toValue newBid -- and lock the new bid in the script output + } + in Just (constraints, newState) + + (Ongoing h@HighestBid{highestBidder, highestBid}, Payout) -> + let + additionalConstraints = getAdditionalPayoutConstraints params state + constraints = + Constraints.mustPayToPubKey highestBidder (aAsset + minAdaTxOutValue) -- and the highest bidder the asset + <> additionalConstraints + <> Constraints.mustValidateIn (Interval.from aEndTime) -- When the auction has ended, + newState = State { stateData = Finished h, stateValue = mempty } + in Just (constraints, newState) + + (Ongoing h@HighestBid{highestBidder, highestBid}, Cancel) -> + let + constraints = + Constraints.mustValidateIn (Interval.to aEndTime) -- While the auction hasn't ended, + <> Constraints.mustPayToPubKey highestBidder (Ada.toValue highestBid) -- and the highest bidder the asset + <> Constraints.mustPayToPubKey aOwner (aAsset + minAdaTxOutValue) -- and the highest bidder the asset + -- TODO: is it okay that buyer receive additional 2ADA? Should we initially add them to the bid price? + newState = State { stateData = Canceled, stateValue = mempty } + in Just (constraints, newState) + + -- Any other combination of 'AuctionState' and 'AuctionInput' is disallowed. + -- This rules out new bids that don't go over the current highest bid. + _ -> Nothing + +{-# INLINABLE auctionStateMachine #-} +auctionStateMachine :: Auction -> AuctionMachine +auctionStateMachine auction = + SM.mkStateMachine (Just $ aProtocolToken auction) (transition $ aAuctionFee auction) isFinal where + isFinal Finished{} = True + isFinal _ = False + transition (Just auctionFee) = auctionTransition (auctionWithFeePayoutConstraints auctionFee) auction + transition Nothing = auctionTransition auctionWithoutFeePayoutConstraints auction + +{-# INLINABLE mkValidator #-} +mkValidator :: Auction -> Scripts.ValidatorType AuctionMachine +mkValidator = SM.mkValidator . auctionStateMachine + +-- | The script instance of the auction state machine. It contains the state +-- machine compiled to a Plutus core validator script. +typedValidator :: Auction -> Scripts.TypedValidator AuctionMachine +typedValidator = Scripts.mkTypedValidatorParam @AuctionMachine + $$(PlutusTx.compile [|| mkValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator + +-- | The machine client of the auction state machine. It contains the script instance +-- with the on-chain code, and the Haskell definition of the state machine for +-- off-chain use. +machineClient + :: Scripts.TypedValidator AuctionMachine + -> Auction + -> StateMachineClient AuctionState AuctionInput +machineClient inst auction = + let machine = auctionStateMachine auction + in SM.mkStateMachineClient (SM.StateMachineInstance machine inst) diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs new file mode 100644 index 000000000..eb3767d04 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs @@ -0,0 +1,5 @@ +module Plutus.Contracts.Services.Sale (module Export) where + +import Plutus.Contracts.Services.Sale.Core as Export +import Plutus.Contracts.Services.Sale.Endpoints as Export +import Plutus.Contracts.Services.Sale.StateMachine as Export diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Core.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Core.hs new file mode 100644 index 000000000..fc99bb56f --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Core.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Plutus.Contracts.Services.Sale.Core where + +import qualified Control.Lens as Lens +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Abstract.Percentage (Percentage) +import qualified Plutus.Abstract.Percentage as Percentage +import Plutus.Contract +import Plutus.Contract.StateMachine +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema + +type Saler = PubKeyHash +type Buyer = PubKeyHash +type LovelacePrice = Integer + +data SaleFee = + SaleFee + { sfSaleOperator :: !PubKeyHash + , sfSaleFee :: !Percentage.Percentage + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''SaleFee + +PlutusTx.makeLift ''SaleFee + +Lens.makeClassy_ ''SaleFee + +data Sale = + Sale + { saleProtocolToken :: !ThreadToken, + salePrice :: !LovelacePrice, + saleValue :: !Value, + saleOwner :: !Saler, + saleOperatorFee :: Maybe SaleFee + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''Sale + +PlutusTx.makeLift ''Sale + diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs new file mode 100644 index 000000000..e3e4c21c1 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.Services.Sale.Endpoints where + +import Control.Monad hiding + (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import qualified Plutus.Abstract.Percentage as Percentage +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core.Marketplace as Marketplace +import qualified Plutus.Contracts.Services.Sale.Core as Core +import qualified Plutus.Contracts.Services.Sale.StateMachine as Core + +import Ext.Plutus.Ledger.Index (minAdaTxOutValue) +import Plutus.Contract.Request (ownPubKeyHash) +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema +import Text.Printf (printf) + +data OpenSaleParams = + OpenSaleParams { + ospSalePrice :: Core.LovelacePrice, + ospSaleValue :: Value, + ospSaleFee :: Maybe Core.SaleFee + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''OpenSaleParams +PlutusTx.makeLift ''OpenSaleParams + +-- | Starts the Sale protocol and mints protocol NFT +openSale :: OpenSaleParams -> Contract w s Text Core.Sale +openSale OpenSaleParams {..} = do + pkh <- ownPubKeyHash + saleToken <- mapError (T.pack . Haskell.show @SMContractError) $ getThreadToken + let sale = Core.Sale + { saleProtocolToken = saleToken, + salePrice = ospSalePrice, + saleValue = ospSaleValue, + saleOwner = pkh, + saleOperatorFee = ospSaleFee + } + let client = Core.saleClient sale + void $ mapError (T.pack . Haskell.show @SMContractError) $ runInitialise client Core.SaleOngoing (ospSaleValue + minAdaTxOutValue) + + logInfo @Haskell.String $ printf "Opened Sale %s at address %s" (Haskell.show sale) (Haskell.show $ Core.saleAddress sale) + pure sale + +-- | The user buys sale value paying sale price +buyLot :: Core.Sale -> Contract w s Text () +buyLot sale = do + pkh <- ownPubKeyHash + let client = Core.saleClient sale + void $ mapError' $ runStep client $ Core.Buy pkh + + logInfo @Haskell.String $ printf "User %s bought lot from sale %s" (Haskell.show pkh) (Haskell.show sale) + pure () + +-- | The user redeems sale value and sale protocol token +redeemLot :: Core.Sale -> Contract w s Text () +redeemLot sale = do + pkh <- ownPubKeyHash + let client = Core.saleClient sale + void $ mapError' $ runStep client Core.Redeem + + logInfo @Haskell.String $ printf "User %s redeemed lot from sale %s" (Haskell.show pkh) (Haskell.show sale) + pure () + +mapError' :: Contract w s SMContractError a -> Contract w s Text a +mapError' = mapError $ T.pack . Haskell.show diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs new file mode 100644 index 000000000..04fea950a --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Plutus.Contracts.Services.Sale.StateMachine where + +import qualified Control.Lens as Lens +import qualified Data.Aeson as J +import qualified Data.Text as T +import Ext.Plutus.Ledger.Index (minAdaTxOutValue) +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Abstract.Percentage (Percentage (..)) +import qualified Plutus.Abstract.Percentage as Percentage +import qualified Plutus.Abstract.PercentageInterface as Percentage +import Plutus.Contract +import Plutus.Contract.StateMachine +import Plutus.Contracts.Services.Sale.Core +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..), (/)) +import qualified Prelude as Haskell +import qualified Schema + +data SaleRedeemer + = Buy Buyer + | Redeem + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''SaleRedeemer + +PlutusTx.makeLift ''SaleRedeemer + +data SaleDatum = + SaleOngoing + | SaleClosed + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''SaleDatum + +PlutusTx.makeLift ''SaleDatum + +type GetAdditionalConstraints = Sale -> TxConstraints Void Void + +saleWithFeeBuyConstraints :: SaleFee -> GetAdditionalConstraints +saleWithFeeBuyConstraints SaleFee {..} Sale {..} = + let saleProfit = salePrice - operatorFee + operatorFee = Percentage.calculatePercentageRounded sfSaleFee salePrice + in + Constraints.mustPayToPubKey saleOwner (Ada.lovelaceValueOf saleProfit) <> + Constraints.mustPayToPubKey sfSaleOperator (Ada.lovelaceValueOf operatorFee) + +saleWithoutFeeBuyConstraints :: GetAdditionalConstraints +saleWithoutFeeBuyConstraints Sale {..} = + Constraints.mustPayToPubKey saleOwner (Ada.lovelaceValueOf salePrice) + +{-# INLINABLE transition #-} +transition :: GetAdditionalConstraints -> Sale -> State SaleDatum -> SaleRedeemer -> Maybe (TxConstraints Void Void, State SaleDatum) +transition additionalConstraints sale@Sale{..} state redeemer = case (stateData state, redeemer) of + (SaleOngoing, Redeem) + -> Just ( Constraints.mustBeSignedBy saleOwner <> + Constraints.mustPayToPubKey saleOwner saleValueWithMinAdaTxOut + , State SaleClosed mempty + ) + (SaleOngoing, Buy buyer) | saleValueWithMinAdaTxOut == val + -> Just ( Constraints.mustBeSignedBy buyer <> + Constraints.mustPayToPubKey buyer saleValueWithMinAdaTxOut <> + -- TODO: is it okay that buyer receive additional 2ADA? Should we initially add them to the sale price? + additionalConstraints sale + , State SaleClosed mempty + ) + _ -> Nothing + where + val = stateValue state + saleValueWithMinAdaTxOut = saleValue + minAdaTxOutValue + +{-# INLINABLE isFinal #-} +isFinal :: SaleDatum -> Bool +isFinal SaleClosed = True +isFinal _ = False + +{-# INLINABLE saleStateMachine #-} +saleStateMachine :: Sale -> StateMachine SaleDatum SaleRedeemer +saleStateMachine sale = StateMachine + { smTransition = getTransition $ saleOperatorFee sale + , smFinal = isFinal + , smCheck = \d r ctx -> True + , smThreadToken = Just $ saleProtocolToken sale + } + where + getTransition (Just fee) = transition (saleWithFeeBuyConstraints fee) sale + getTransition Nothing = transition saleWithoutFeeBuyConstraints sale + +{-# INLINABLE mkSaleValidator #-} +mkSaleValidator :: Sale -> SaleDatum -> SaleRedeemer -> ScriptContext -> Bool +mkSaleValidator sale = mkValidator $ saleStateMachine sale + +type SaleScript = StateMachine SaleDatum SaleRedeemer + +saleInst :: Sale -> Scripts.TypedValidator SaleScript +saleInst sale = Scripts.mkTypedValidator @SaleScript + ($$(PlutusTx.compile [|| mkSaleValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode sale) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @SaleDatum @SaleRedeemer + +saleClient :: Sale -> StateMachineClient SaleDatum SaleRedeemer +saleClient sale = mkStateMachineClient $ StateMachineInstance (saleStateMachine sale) (saleInst sale) + +saleValidator :: Sale -> Validator +saleValidator = Scripts.validatorScript . saleInst + +saleAddress :: Sale -> Ledger.Address +saleAddress = scriptAddress . saleValidator diff --git a/MetaLamp/nft-marketplace/src/Plutus/PAB/MarketplaceContracts.hs b/MetaLamp/nft-marketplace/src/Plutus/PAB/MarketplaceContracts.hs new file mode 100644 index 000000000..ca627ad86 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/PAB/MarketplaceContracts.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.PAB.MarketplaceContracts where + +import qualified Data.Aeson as J +import qualified Data.OpenApi.Schema as OpenApi +import Data.Text.Prettyprint.Doc (Pretty (..), + viaShow) +import GHC.Generics (Generic) +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import Plutus.PAB.Effects.Contract.Builtin (Builtin, + SomeBuiltin (..), + type (.\\)) +import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin +import Plutus.PAB.Run.PSGenerator (HasPSTypes (..)) + +data MarketplaceContracts = + MarketplaceStart + | MarketplaceInfo Marketplace.Marketplace + | MarketplaceUser Marketplace.Marketplace + deriving (Eq, Show, Generic, Ord) + deriving anyclass (J.FromJSON, J.ToJSON, OpenApi.ToSchema) + +instance HasPSTypes MarketplaceContracts where + psTypes = [] + +instance Pretty MarketplaceContracts where + pretty = viaShow + +instance Builtin.HasDefinitions MarketplaceContracts where + getDefinitions = [MarketplaceStart] + getSchema = \case + MarketplaceUser _ -> Builtin.endpointsToSchemas @Marketplace.MarketplaceUserSchema + MarketplaceInfo _ -> Builtin.endpointsToSchemas @Marketplace.MarketplaceInfoSchema + MarketplaceStart -> Builtin.endpointsToSchemas @Marketplace.MarketplaceOwnerSchema + getContract = \case + MarketplaceInfo marketplace -> SomeBuiltin . awaitPromise $ Marketplace.infoEndpoints marketplace + MarketplaceUser marketplace -> SomeBuiltin . awaitPromise $ Marketplace.userEndpoints marketplace + MarketplaceStart -> SomeBuiltin . awaitPromise $ Marketplace.ownerEndpoints diff --git a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs new file mode 100644 index 000000000..cb82776fc --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.PAB.Simulation where + +import Control.Concurrent (forkIO) +import Control.Monad (forM, forM_, + void, when) +import Control.Monad.Freer (Eff, Member, + interpret, + type (~>)) +import Control.Monad.Freer.Error (Error) +import Control.Monad.Freer.Extras.Log (LogMsg) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Aeson as J +import Data.Default (Default (def)) +import qualified Data.Map.Strict as Map +import Data.Monoid (Last (..)) +import qualified Data.Monoid as Monoid +import qualified Data.OpenApi.Schema as OpenApi +import Data.Proxy (Proxy (..)) +import qualified Data.Semigroup as Semigroup +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty (..), + viaShow) +import qualified Data.Time.Clock as Time +import Ext.Plutus.Ledger.Time (Seconds (..), + addToBeginningOfTime, + convertUtcToPOSIX) +import qualified Ext.Plutus.PAB.Webserver.Server as Ext.Plutus.PAB +import GHC.Generics (Generic) +import Ledger +import Ledger.Ada (adaSymbol, + adaToken, + adaValueOf, + lovelaceValueOf) +import qualified Ledger.Ada as Ada +import Ledger.Constraints +import qualified Ledger.Constraints.OffChain as Constraints +import Ledger.TimeSlot (SlotConfig (..)) +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value as Value +import Network.HTTP.Client (defaultManagerSettings, + newManager) +import Playground.Types (SimulatorWallet (..), + adaCurrency) +import Plutus.Abstract.ContractResponse (ContractResponse, + ContractState (..)) +import Plutus.Abstract.RemoteData (RemoteData (..)) +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OffChain.Owner as Owner +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Contracts.Services.Sale as Sale +import Plutus.PAB.Effects.Contract (ContractEffect (..)) +import Plutus.PAB.Effects.Contract.Builtin (Builtin, + SomeBuiltin (..), + type (.\\)) +import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin +import Plutus.PAB.MarketplaceContracts (MarketplaceContracts (..)) +import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg) +import Plutus.PAB.Simulator (Simulation, + SimulatorEffectHandlers) +import qualified Plutus.PAB.Simulator as Simulator +import Plutus.PAB.Types (PABError (..)) +import qualified Plutus.PAB.Types as PAB +import qualified Plutus.PAB.Webserver.Server as PAB +import Plutus.V1.Ledger.Time (DiffMilliSeconds (..), + POSIXTime (..), + fromMilliSeconds) +import Prelude hiding (init) +import Servant.Client (BaseUrl (..), + Scheme (..), + mkClientEnv) +import Wallet.Emulator.Types (WalletNumber (..), + walletPubKeyHash) +import Wallet.Emulator.Wallet (Wallet (..), + fromWalletNumber) +import Wallet.Types (ContractInstanceId) + +ownerWallet :: Wallet +ownerWallet = fromWalletNumber $ WalletNumber 1 + +wallet2 :: Wallet +wallet2 = fromWalletNumber $ WalletNumber 2 + +wallet3 :: Wallet +wallet3 = fromWalletNumber $ WalletNumber 3 + +userWallets :: [Wallet] +userWallets = fromWalletNumber <$> [WalletNumber i | i <- [2 .. 4]] + +startMarketplaceParams :: Owner.StartMarketplaceParams +startMarketplaceParams = Owner.StartMarketplaceParams { + creationFee = 100000, -- 0.1 ADA + saleFee = (5, 2) +} + +initialLotPrice :: Value.Value +initialLotPrice = lovelaceValueOf 100000000 -- 100 ADA + +data ContractIDs = ContractIDs { cidUser :: Map.Map Wallet ContractInstanceId, cidInfo :: ContractInstanceId } + +activateContracts :: Simulation (Builtin MarketplaceContracts) ContractIDs +activateContracts = do + cidStart <- Simulator.activateContract ownerWallet MarketplaceStart + _ <- Simulator.callEndpointOnInstance cidStart "start" startMarketplaceParams + mp <- flip Simulator.waitForState cidStart $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.OwnerContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.Started mp))))) -> Just mp + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Marketplace instance created: " ++ show mp + + cidInfo <- Simulator.activateContract ownerWallet $ MarketplaceInfo mp + + users <- fmap Map.fromList $ forM userWallets $ \w -> do + cid <- Simulator.activateContract w $ MarketplaceUser mp + Simulator.logString @(Builtin MarketplaceContracts) $ "Marketplace user contract started for " ++ show w + return (w, cid) + + pure $ ContractIDs users cidInfo + +startMpServer :: IO () +startMpServer = do + beginningOfTime <- convertUtcToPOSIX <$> Time.getCurrentTime + void $ Simulator.runSimulationWith (handlers $ slotConfiguration beginningOfTime) $ do + Simulator.logString @(Builtin MarketplaceContracts) "Starting NFT Marketplace PAB webserver on port 9080. Press enter to exit." + shutdown <- Ext.Plutus.PAB.startServer + + ContractIDs {..} <- activateContracts + + manager <- liftIO . newManager $ defaultManagerSettings + + Simulator.logString @(Builtin MarketplaceContracts) "NFT Marketplace PAB webserver started on port 9080. Initialization complete. Press enter to exit." + _ <- liftIO getLine + shutdown + +runNftMarketplace :: IO () +runNftMarketplace = + void $ Simulator.runSimulationWith (handlers def) $ do + Simulator.logString @(Builtin MarketplaceContracts) "Starting Marketplace PAB webserver on port 9080. Press enter to exit." + shutdown <- PAB.startServerDebug + ContractIDs {..} <- activateContracts + let userCid = cidUser Map.! wallet2 + sender = walletPubKeyHash $ wallet2 + let catTokenIpfsCid = "QmPeoJnaDttpFrSySYBY3reRFCzL3qv4Uiqz376EBv9W16" + let photoTokenIpfsCid = "QmeSFBsEZ7XtK7yv5CQ79tqFnH9V2jhFhSSq1LV5W3kuiB" + + _ <- Simulator.callEndpointOnInstance cidInfo "marketplaceSettings" () + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.MarketplaceSettings v))))) -> Just v + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "MarketplaceSettings: " <> show v + + _ <- + Simulator.callEndpointOnInstance userCid "createNft" $ + Marketplace.CreateNftParams { + cnpIpfsCid = catTokenIpfsCid, + cnpNftName = "Cat token", + cnpNftDescription = "A picture of a cat on a pogo stick", + cnpNftCategory = ["GIFs"], + cnpRevealIssuer = False + } + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.NftCreated)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" + + _ <- + Simulator.callEndpointOnInstance userCid "openSale" $ + Marketplace.OpenSaleParams { + ospItemId = Marketplace.UserNftId catTokenIpfsCid, + ospSalePrice = 44*oneAdaInLovelace + } + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.OpenedSale)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" + + let buyerCid = cidUser Map.! wallet3 + buyer = walletPubKeyHash wallet3 + + _ <- + Simulator.callEndpointOnInstance buyerCid "buyItem" Marketplace.CloseLotParams { + clpItemId = Marketplace.UserNftId catTokenIpfsCid + } + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.NftBought)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful buyItem" + + _ <- + Simulator.callEndpointOnInstance userCid "createNft" $ + Marketplace.CreateNftParams { + cnpIpfsCid = photoTokenIpfsCid, + cnpNftName = "Photo token", + cnpNftDescription = "A picture of a sunset", + cnpNftCategory = ["Photos"], + cnpRevealIssuer = True + } + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.NftCreated)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" + + _ <- Simulator.waitNSlots 10 + + _ <- + Simulator.callEndpointOnInstance userCid "openSale" $ + Marketplace.OpenSaleParams { + ospItemId = Marketplace.UserNftId photoTokenIpfsCid, + ospSalePrice = 12*oneAdaInLovelace + } + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.OpenedSale)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" + + _ <- Simulator.waitNSlots 10 + + _ <- + Simulator.callEndpointOnInstance userCid "closeSale" + Marketplace.CloseLotParams { + clpItemId = Marketplace.UserNftId photoTokenIpfsCid + } + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.ClosedSale)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful closeSale" + + let auction = Marketplace.StartAnAuctionParams { + saapItemId = Marketplace.UserNftId photoTokenIpfsCid, + saapInitialPrice = fromInteger $ 5 * oneAdaInLovelace, + saapEndTime = addToBeginningOfTime $ Seconds 55 + } + _ <- + Simulator.callEndpointOnInstance userCid "startAnAuction" auction + _ <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.AuctionStarted)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Started An Auction" + + _ <- + Simulator.callEndpointOnInstance buyerCid "bidOnAuction" Marketplace.BidOnAuctionParams { + boapItemId = Marketplace.UserNftId photoTokenIpfsCid, + boapBid = fromInteger $ 15 * oneAdaInLovelace + } + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.BidSubmitted)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful bidOnAuction" + + _ <- Simulator.callEndpointOnInstance cidInfo "getAuctionState" $ Marketplace.UserNftId photoTokenIpfsCid + s <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.AuctionState s))))) -> Just s + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final auction state: " <> show s + + _ <- + Simulator.callEndpointOnInstance buyerCid "completeAnAuction" $ Marketplace.CloseLotParams $ Marketplace.UserNftId photoTokenIpfsCid + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.AuctionComplete)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful holdAnAuction" + + _ <- + Simulator.callEndpointOnInstance userCid "bundleUp" $ + Marketplace.BundleUpParams { + bupIpfsCids = [photoTokenIpfsCid,catTokenIpfsCid], + bupName = "Picture gallery", + bupDescription = "Collection of visual media", + bupCategory = ["User","Stan"] + } + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.Bundled)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful bundleUp" + + _ <- + Simulator.callEndpointOnInstance userCid "unbundle" $ + Marketplace.UnbundleParams { + upIpfsCids = [photoTokenIpfsCid,catTokenIpfsCid] + } + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.UserContractState)) of + J.Success (Last (Just (ContractState _ (Success Marketplace.Unbundled)))) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful unbundle" + + _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" buyer + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.FundsAt v))))) -> Just v + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final buyer funds: " <> show v + + _ <- Simulator.callEndpointOnInstance cidInfo "marketplaceStore" () + marketplaceStore <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.MarketplaceStore marketplaceStore))))) -> Just marketplaceStore + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final marketplaceStore: " <> show marketplaceStore + + _ <- Simulator.callEndpointOnInstance cidInfo "marketplaceFunds" () + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.MarketplaceFunds v))))) -> Just v + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final marketplace funds: " <> show v + + _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" sender + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse String Text Marketplace.InfoContractState)) of + J.Success (Last (Just (ContractState _ (Success (Marketplace.FundsAt v))))) -> Just v + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final user funds: " <> show v + + _ <- liftIO getLine + shutdown + +slotConfiguration :: POSIXTime -> SlotConfig +slotConfiguration beginningOfTime = SlotConfig + { scSlotLength = 1000 + , scSlotZeroTime = beginningOfTime + } + +handlers :: SlotConfig -> SimulatorEffectHandlers (Builtin MarketplaceContracts) +handlers slotConfig = + Simulator.mkSimulatorHandlers def slotConfig + $ interpret (Builtin.contractHandler (Builtin.handleBuiltin @MarketplaceContracts)) + +oneAdaInLovelace :: Integer +oneAdaInLovelace = 1000000 diff --git a/MetaLamp/nft-marketplace/test/Abstract/Percentage.hs b/MetaLamp/nft-marketplace/test/Abstract/Percentage.hs new file mode 100644 index 000000000..e48bff35c --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Abstract/Percentage.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Abstract.Percentage + ( tests + ) where + +import Plutus.Abstract.Percentage +import Prelude +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "mkPercentage" + [ testCase "should make Percentage" $ + (mkPercentage (5, 2)) @?= (Just $ Percentage (5, 2)) + , testCase "should return Nothing if denominator is 0" $ + (mkPercentage (5, 0)) @?= Nothing + , testCase "should return Nothing if the value is gte 100%" $ + (mkPercentage (400, 2)) @?= Nothing + ] diff --git a/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs new file mode 100644 index 000000000..8014a07db --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Abstract.RemoteDataSpec + ( tests + ) where + +import Plutus.Abstract.RemoteData (RemoteData (..)) +import qualified Test.QuickCheck.Property.Common as Q +import qualified Test.QuickCheck.Property.Monoid as Q +import Test.Tasty +import qualified Test.Tasty.QuickCheck as Q + +tests :: TestTree +tests = + Q.testProperty "RemoteData Monoid instance" $ + Q.eq $ Q.prop_Monoid (Q.T :: Q.T (RemoteData String Int)) diff --git a/MetaLamp/nft-marketplace/test/Main.hs b/MetaLamp/nft-marketplace/test/Main.hs new file mode 100644 index 000000000..42c7dac2b --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Main.hs @@ -0,0 +1,25 @@ +module Main + ( main + ) where + +import qualified Abstract.Percentage as Percentage +import qualified Abstract.RemoteDataSpec as RemoteData +import qualified Marketplace.Spec.Auction as Auction +import qualified Marketplace.Spec.Bundles as Bundles +import qualified Marketplace.Spec.CreateNft as CreateNft +import qualified Marketplace.Spec.Sale as Sale +import qualified Marketplace.Spec.Start as Start +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "All tests" + [ testGroup + "NFT Marketplace" + [Start.tests, CreateNft.tests, Bundles.tests, Auction.tests, Sale.tests] + , testGroup "Abstract" [RemoteData.tests, Percentage.tests] + ] diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Fixtures.hs b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures.hs new file mode 100644 index 000000000..a36c83962 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures.hs @@ -0,0 +1,8 @@ +module Marketplace.Fixtures + ( module Export + ) where + +import Marketplace.Fixtures.CheckOptions as Export +import Marketplace.Fixtures.NFT as Export +import Marketplace.Fixtures.Script as Export +import Marketplace.Fixtures.Wallet as Export diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/CheckOptions.hs b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/CheckOptions.hs new file mode 100644 index 000000000..ea4ca2a75 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/CheckOptions.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Marketplace.Fixtures.CheckOptions where + +import Control.Lens ((&), (.~)) +import Data.Default (Default (def)) +import qualified Data.Map as Map +import Ext.Plutus.Ledger.Time (beginningOfTime) +import Ledger (Value) +import qualified Ledger.Ada as Ada +import Ledger.TimeSlot (SlotConfig (..)) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures.Wallet as Fixtures +import Plutus.Contract.Test +import Plutus.Contract.Trace (defaultDist) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Trace as Trace +import Plutus.V1.Ledger.Time (POSIXTime (..)) + +options :: CheckOptions +options = defaultCheckOptions & emulatorConfig .~ emulatorCfg + where + emulatorCfg :: Trace.EmulatorConfig + emulatorCfg = Trace.EmulatorConfig (Left defaultDist) slotConfiguration def + +slotConfiguration :: SlotConfig +slotConfiguration = SlotConfig + { scSlotLength = 1000 + , scSlotZeroTime = beginningOfTime + } diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/NFT.hs b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/NFT.hs new file mode 100644 index 000000000..5377b346c --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/NFT.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Marketplace.Fixtures.NFT where + +import Data.Text (Text) +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import PlutusTx.Builtins (sha2_256) +import PlutusTx.Prelude (BuiltinByteString) + +cids :: [Text] +cids = [catTokenIpfsCid, photoTokenIpfsCid] + +bundleId :: Marketplace.BundleId +bundleId = Marketplace.calcBundleIdHash $ fmap Marketplace.deserializeByteString cids + +bundleInfo :: Marketplace.BundleInfo +bundleInfo = Marketplace.BundleInfo + { biName = Marketplace.deserializePlutusBuiltinBS bundleName + , biDescription = Marketplace.deserializePlutusBuiltinBS bundleDescription + , biCategory = Marketplace.deserializePlutusBuiltinBS <$> bundleCategory + } + +bundleName :: Text +bundleName = "Picture gallery" + +bundleDescription :: Text +bundleDescription = "Collection of visual media" + +bundleCategory :: [Text] +bundleCategory = ["User","Stan"] + +catTokenIpfsCid :: Text +catTokenIpfsCid = "QmPeoJnaDttpFrSySYBY3reRFCzL3qv4Uiqz376EBv9W16" + +catTokenIpfsCidBs :: BuiltinByteString +catTokenIpfsCidBs = "QmPeoJnaDttpFrSySYBY3reRFCzL3qv4Uiqz376EBv9W16" + +catTokenIpfsCidHash :: Marketplace.IpfsCidHash +catTokenIpfsCidHash = sha2_256 $ Marketplace.deserializeByteString catTokenIpfsCid + +catTokenName :: Text +catTokenName = "Cat token" + +catTokenDescription :: Text +catTokenDescription = "A picture of a cat on a pogo stick" + +catTokenCategory :: [Text] +catTokenCategory = ["GIFs"] + +hasCatTokenRecord :: Marketplace.NftInfo -> Bool +hasCatTokenRecord Marketplace.NftInfo {..} = + niCategory == (Marketplace.deserializePlutusBuiltinBS <$> catTokenCategory) && + niName == (Marketplace.deserializePlutusBuiltinBS catTokenName) && + niDescription == (Marketplace.deserializePlutusBuiltinBS catTokenDescription) + +photoTokenIpfsCid :: Text +photoTokenIpfsCid = "QmeSFBsEZ7XtK7yv5CQ79tqFnH9V2jhFhSSq1LV5W3kuiB" + +photoTokenIpfsCidBs :: BuiltinByteString +photoTokenIpfsCidBs = "QmeSFBsEZ7XtK7yv5CQ79tqFnH9V2jhFhSSq1LV5W3kuiB" + +photoTokenIpfsCidHash :: Marketplace.IpfsCidHash +photoTokenIpfsCidHash = sha2_256 $ Marketplace.deserializeByteString photoTokenIpfsCid + +photoTokenName :: Text +photoTokenName = "Photo token" + +photoTokenDescription :: Text +photoTokenDescription = "A picture of a sunset" + +photoTokenCategory :: [Text] +photoTokenCategory = ["Photos"] + +hasPhotoTokenRecord :: Marketplace.NftInfo -> Bool +hasPhotoTokenRecord Marketplace.NftInfo {..} = + niCategory == (Marketplace.deserializePlutusBuiltinBS <$> photoTokenCategory) && + niName == (Marketplace.deserializePlutusBuiltinBS photoTokenName) && + niDescription == (Marketplace.deserializePlutusBuiltinBS photoTokenDescription) + +oneAdaInLovelace :: Integer +oneAdaInLovelace = 1000000 diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Script.hs b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Script.hs new file mode 100644 index 000000000..3123792d5 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Script.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +module Marketplace.Fixtures.Script where + +import Ledger (Address, + CurrencySymbol, + pubKeyHash) +import Ledger.Ada (Ada (..)) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures.Wallet as Fixtures +import Plutus.Abstract.Percentage (Percentage (..)) +import Plutus.Abstract.PercentageInterface (calculatePercentageRounded) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import Wallet.Emulator.Types (Wallet (..), + walletPubKeyHash) + +marketplace :: Marketplace.Marketplace +marketplace = + Marketplace.Marketplace { + Marketplace.marketplaceOperator = walletPubKeyHash Fixtures.ownerWallet, + Marketplace.marketplaceSaleFee = percentage, + Marketplace.marketplaceNFTFee = marketplaceCreationFee + } + +marketplaceCreationFee :: Ada +marketplaceCreationFee = Lovelace 2_100_000 -- 2.1 ADA (should be gte then minAdaTxOut) + +percentage :: Percentage +percentage = Percentage (7, 2) + +roundedPercentage :: Integer -> Integer +roundedPercentage price = calculatePercentageRounded percentage price + +marketplaceAddress :: Address +marketplaceAddress = Marketplace.marketplaceAddress marketplace diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Wallet.hs b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Wallet.hs new file mode 100644 index 000000000..ae2f63733 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Fixtures/Wallet.hs @@ -0,0 +1,16 @@ +module Marketplace.Fixtures.Wallet where + +import Wallet.Emulator.Types (WalletNumber (..)) +import Wallet.Emulator.Wallet (Wallet (..), fromWalletNumber) + +ownerWallet :: Wallet +ownerWallet = fromWalletNumber $ WalletNumber 1 + +userWallet :: Wallet +userWallet = fromWalletNumber $ WalletNumber 2 + +buyerWallet :: Wallet +buyerWallet = fromWalletNumber $ WalletNumber 3 + +userWallets :: [Wallet] +userWallets = [userWallet, buyerWallet] diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs new file mode 100644 index 000000000..c2fc5a312 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Marketplace.Spec.Auction + ( tests + , startAnAuctionTrace + , startAnAuctionTrace' + , completeAnAuctionTrace + , completeAnAuctionTrace' + , bidOnAuctionTrace + , bidOnAuctionTrace' + , buyOnAuctionTrace + , cancelAuctionWithBidsTrace + , cancelAuctionWithoutBidsTrace + , cancelAuctionWhenTimeIsOverTrace + ) where + +import Control.Lens (_2, _Right, (&), + (^.), (^?)) +import Control.Monad (void) +import Data.Foldable (find) +import Data.Maybe (isNothing) +import Data.Proxy +import Data.Text (Text) +import Data.Void (Void) +import Ext.Plutus.Ledger.Time (Seconds (..), + addToBeginningOfTime) +import Ledger (Value) +import Ledger.Ada (Ada (..), + lovelaceValueOf, + toValue) +import Ledger.Index (minAdaTxOut) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures as Fixtures +import qualified Marketplace.Spec.Bundles as Bundles +import qualified Marketplace.Spec.CreateNft as CreateNft +import qualified Marketplace.Spec.Start as Start +import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Contract.Test +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Contracts.Services.Auction.Core as Auction +import qualified Plutus.Trace as Trace +import Plutus.V1.Ledger.Time (DiffMilliSeconds (..), + POSIXTime (..), + fromMilliSeconds) +import qualified PlutusTx.AssocMap as AssocMap +import Test.Tasty +import qualified Utils +import Wallet.Emulator.Wallet (walletAddress) + + +tests :: TestTree +tests = + testGroup + "Auction" + [testGroup + "NFT singletons" + [ + checkPredicateOptions + Fixtures.options + "Should open an auction for one NFT locking it in auction script & saving link" + (startAnAuctionValueCheck .&&. startAnAuctionDatumsCheck) + (void startAnAuctionTrace), + checkPredicateOptions + Fixtures.options + "Should not put on auction if NFT does not exist" + errorCheckStart + startAnAuctionTrace', + checkPredicateOptions + Fixtures.options + "Should close auction and pay locked NFT back if there were no bids" + (completeAnAuctionValueCheck .&&. completeAuctionDatumsCheck) + completeAnAuctionTrace, + checkPredicateOptions + Fixtures.options + "Should not close auction if it was not started" + errorCheckComplete + completeAnAuctionTrace', + checkPredicateOptions + Fixtures.options + "Should bid on NFT" + startAnAuctionDatumsCheck + (void bidOnAuctionTrace), + checkPredicateOptions + Fixtures.options + "Should not bid if NFT is not on auction" + errorCheckBid + bidOnAuctionTrace', + checkPredicateOptions + Fixtures.options + "Should close auction and pay locked NFT to the highest bidder" + (buyOnAuctionValueCheck .&&. completeAuctionDatumsCheck) + buyOnAuctionTrace, + checkPredicateOptions + Fixtures.options + "Should close auction and pay marketplace operator a saleFee" + (marketplaceOperatorFeeCheck .&&. sellerProfitWithFeeCheck) + buyOnAuctionTrace, + checkPredicateOptions + Fixtures.options + "Should cancel auction and get NFT back to owner when no bids" + (cancelAuctionDatumsCheck .&&. cancelAnAuctionValueCheck) + cancelAuctionWithoutBidsTrace, + checkPredicateOptions + Fixtures.options + "Should cancel auction and get NFT and bid back to owner and bidder" + (cancelAuctionDatumsCheck .&&. cancelAnAuctionValueCheck .&&. cancelAnAuctionBidReturningCheck) + cancelAuctionWithBidsTrace, + checkPredicateOptions + Fixtures.options + "Should not cancel auction if time is over" + errorCheckCancel + cancelAuctionWhenTimeIsOverTrace + ], + testGroup + "NFT bundles" + [ + checkPredicateOptions + Fixtures.options + "Should open an auction for NFT bundle locking its value in auction script & saving link" + (startAnAuctionValueCheckB .&&. startAnAuctionDatumsCheckB) + (void startAnAuctionTraceB), + checkPredicateOptions + Fixtures.options + "Should not put on auction if bundle does not exist" + errorCheckStart + startAnAuctionTraceB', + checkPredicateOptions + Fixtures.options + "Should close auction and pay locked bundle value back if there were no bids" + (completeAnAuctionValueCheckB .&&. completeAuctionDatumsCheckB) + completeAnAuctionTraceB, + checkPredicateOptions + Fixtures.options + "Should bid on bundle" + startAnAuctionDatumsCheckB + (void bidOnAuctionTraceB), + checkPredicateOptions + Fixtures.options + "Should close auction and pay locked bundle value to the highest bidder" + (buyOnAuctionValueCheckB .&&. completeAuctionDatumsCheckB) + buyOnAuctionTraceB, + checkPredicateOptions + Fixtures.options + "Should close bundle auction and pay marketplace operator a saleFee" + (marketplaceOperatorFeeCheckB .&&. sellerProfitWithFeeCheckB) + buyOnAuctionTraceB, + checkPredicateOptions + Fixtures.options + "Should cancel auction and get bundle back to owner when no bids" + (cancelAuctionDatumsCheckB .&&. cancelAnAuctionValueCheckB) + cancelAuctionWithoutBidsTraceB, + checkPredicateOptions + Fixtures.options + "Should cancel auction and get bundle and bid back to owner and bidder" + (cancelAuctionDatumsCheckB .&&. cancelAnAuctionValueCheckB .&&. cancelAnAuctionBidReturningCheckB) + cancelAuctionWithBidsTraceB + ]] + +-- \/\/\/ "NFT singletons" +startAnAuctionParams :: Marketplace.StartAnAuctionParams +startAnAuctionParams = Marketplace.StartAnAuctionParams + { + Marketplace.saapItemId = Marketplace.UserNftId Fixtures.catTokenIpfsCid, + Marketplace.saapEndTime = addToBeginningOfTime $ Seconds 155, + Marketplace.saapInitialPrice = fromInteger $ 5 * Fixtures.oneAdaInLovelace + } + +closeLotParams :: Marketplace.CloseLotParams +closeLotParams = Marketplace.CloseLotParams { + Marketplace.clpItemId = Marketplace.UserNftId Fixtures.catTokenIpfsCid + } + +highestBid :: Integer +highestBid = 75 * Fixtures.oneAdaInLovelace + +bidOnAuctionParams :: Marketplace.BidOnAuctionParams +bidOnAuctionParams = Marketplace.BidOnAuctionParams { + Marketplace.boapItemId = Marketplace.UserNftId Fixtures.catTokenIpfsCid, + Marketplace.boapBid = fromInteger $ 75 * Fixtures.oneAdaInLovelace + } + +startAnAuctionTrace :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +startAnAuctionTrace = do + h <- CreateNft.createNftTrace + + _ <- Trace.callEndpoint @"startAnAuction" h startAnAuctionParams + + _ <- Trace.waitNSlots 50 + pure h + +startAnAuctionTrace' :: Trace.EmulatorTrace () +startAnAuctionTrace' = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"startAnAuction" h startAnAuctionParams + + _ <- Trace.waitNSlots 50 + pure () + +completeAnAuctionTrace :: Trace.EmulatorTrace () +completeAnAuctionTrace = do + h <- startAnAuctionTrace + + _ <- Trace.callEndpoint @"completeAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 250 + pure () + +completeAnAuctionTrace' :: Trace.EmulatorTrace () +completeAnAuctionTrace' = do + h <- CreateNft.createNftTrace + + _ <- Trace.callEndpoint @"completeAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +bidOnAuctionTrace :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +bidOnAuctionTrace = do + _ <- startAnAuctionTrace + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"bidOnAuction" h bidOnAuctionParams + + _ <- Trace.waitNSlots 50 + pure h + +bidOnAuctionTrace' :: Trace.EmulatorTrace () +bidOnAuctionTrace' = do + _ <- CreateNft.createNftTrace + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"bidOnAuction" h bidOnAuctionParams + + _ <- Trace.waitNSlots 50 + pure () + +buyOnAuctionTrace :: Trace.EmulatorTrace () +buyOnAuctionTrace = do + h <- bidOnAuctionTrace + + _ <- Trace.callEndpoint @"completeAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 250 + pure () + +cancelAuctionWithBidsTrace :: Trace.EmulatorTrace () +cancelAuctionWithBidsTrace = do + h <- startAnAuctionTrace + + h1 <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"bidOnAuction" h1 bidOnAuctionParams + _ <- Trace.callEndpoint @"cancelAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +cancelAuctionWithoutBidsTrace :: Trace.EmulatorTrace () +cancelAuctionWithoutBidsTrace = do + h <- startAnAuctionTrace + _ <- Trace.callEndpoint @"cancelAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +cancelAuctionWhenTimeIsOverTrace :: Trace.EmulatorTrace () +cancelAuctionWhenTimeIsOverTrace = do + h <- CreateNft.createNftTrace + let startAuctionParamsWithLessTime = startAnAuctionParams {Marketplace.saapEndTime = addToBeginningOfTime $ Seconds 5} + + _ <- Trace.callEndpoint @"startAnAuction" h startAuctionParamsWithLessTime + + _ <- Trace.waitNSlots 50 + + _ <- Trace.callEndpoint @"cancelAnAuction" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +startAnAuctionDatumsCheck :: TracePredicate +startAnAuctionDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (nftIsOnAuction . Marketplace.mdSingletons)) + where + nftIsOnAuction = maybe False (\t -> Marketplace.getAuctionFromNFT t & fmap Auction.aAsset & + (== Just (Marketplace.nftValue Fixtures.catTokenIpfsCidBs t))) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +completeAuctionDatumsCheck :: TracePredicate +completeAuctionDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (nftNotOnAuction . Marketplace.mdSingletons)) + where + nftNotOnAuction = maybe False (isNothing . Marketplace.nftLot) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +startAnAuctionValueCheck :: TracePredicate +startAnAuctionValueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (isNothing . find hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +completeAnAuctionValueCheck :: TracePredicate +completeAnAuctionValueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +cancelAuctionDatumsCheck :: TracePredicate +cancelAuctionDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (nftNotOnAuction . Marketplace.mdSingletons)) + where + nftNotOnAuction = maybe False (isNothing . Marketplace.nftLot) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +cancelAnAuctionValueCheck :: TracePredicate +cancelAnAuctionValueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +cancelAnAuctionBidReturningCheck :: TracePredicate +cancelAnAuctionBidReturningCheck = + walletFundsChange Fixtures.buyerWallet $ lovelaceValueOf 0 + +buyOnAuctionValueCheck :: TracePredicate +buyOnAuctionValueCheck = + valueAtAddress + (walletAddress Fixtures.buyerWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +errorCheckStart :: TracePredicate +errorCheckStart = Utils.assertCrError (Proxy @"startAnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckComplete :: TracePredicate +errorCheckComplete = Utils.assertCrError (Proxy @"completeAnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckBid :: TracePredicate +errorCheckBid = Utils.assertCrError (Proxy @"bidOnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) + +errorCheckCancel :: TracePredicate +errorCheckCancel = Utils.assertCrError (Proxy @"cancelAnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +-- \/\/\/ "NFT bundles" +startAnAuctionParamsB :: Marketplace.StartAnAuctionParams +startAnAuctionParamsB = Marketplace.StartAnAuctionParams + { + Marketplace.saapItemId = Marketplace.UserBundleId Fixtures.cids, + Marketplace.saapEndTime = addToBeginningOfTime $ Seconds 300, + Marketplace.saapInitialPrice = fromInteger $ 15 * Fixtures.oneAdaInLovelace + } + +closeLotParamsB :: Marketplace.CloseLotParams +closeLotParamsB = Marketplace.CloseLotParams { + Marketplace.clpItemId = Marketplace.UserBundleId Fixtures.cids + } + +highestBidB :: Integer +highestBidB = 95 * Fixtures.oneAdaInLovelace + +bidOnAuctionParamsB :: Marketplace.BidOnAuctionParams +bidOnAuctionParamsB = Marketplace.BidOnAuctionParams { + Marketplace.boapItemId = Marketplace.UserBundleId Fixtures.cids, + Marketplace.boapBid = fromInteger highestBidB + } + +startAnAuctionTraceB :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +startAnAuctionTraceB = do + h <- Bundles.bundleTrace + + _ <- Trace.callEndpoint @"startAnAuction" h startAnAuctionParamsB + + _ <- Trace.waitNSlots 50 + pure h + +startAnAuctionTraceB' :: Trace.EmulatorTrace () +startAnAuctionTraceB' = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"startAnAuction" h startAnAuctionParamsB + + _ <- Trace.waitNSlots 50 + pure () + +completeAnAuctionTraceB :: Trace.EmulatorTrace () +completeAnAuctionTraceB = do + h <- startAnAuctionTraceB + + _ <- Trace.callEndpoint @"completeAnAuction" h closeLotParamsB + + _ <- Trace.waitNSlots 250 + pure () + +bidOnAuctionTraceB :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +bidOnAuctionTraceB = do + _ <- startAnAuctionTraceB + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"bidOnAuction" h bidOnAuctionParamsB + + _ <- Trace.waitNSlots 50 + pure h + +buyOnAuctionTraceB :: Trace.EmulatorTrace () +buyOnAuctionTraceB = do + h <- bidOnAuctionTraceB + + _ <- Trace.callEndpoint @"completeAnAuction" h closeLotParamsB + + _ <- Trace.waitNSlots 250 + pure () + +cancelAuctionWithBidsTraceB :: Trace.EmulatorTrace () +cancelAuctionWithBidsTraceB = do + h <- startAnAuctionTraceB + + h1 <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"bidOnAuction" h1 bidOnAuctionParamsB + _ <- Trace.callEndpoint @"cancelAnAuction" h closeLotParamsB + + _ <- Trace.waitNSlots 50 + pure () + +cancelAuctionWithoutBidsTraceB :: Trace.EmulatorTrace () +cancelAuctionWithoutBidsTraceB = do + h <- startAnAuctionTraceB + _ <- Trace.callEndpoint @"cancelAnAuction" h closeLotParamsB + + _ <- Trace.waitNSlots 50 + pure () + +startAnAuctionDatumsCheckB :: TracePredicate +startAnAuctionDatumsCheckB = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (bundleIsOnAuction . Marketplace.mdBundles)) + where + bundleIsOnAuction = maybe False (\b -> Marketplace.getAuctionFromBundle b & fmap Auction.aAsset & + (== Just (Marketplace.bundleValue AssocMap.empty b))) . + AssocMap.lookup Fixtures.bundleId + +completeAuctionDatumsCheckB :: TracePredicate +completeAuctionDatumsCheckB = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (bundleNotOnAuction . Marketplace.mdBundles)) + where + bundleNotOnAuction = maybe False (Prelude.not . Marketplace.hasLotBundle) . + AssocMap.lookup Fixtures.bundleId + +startAnAuctionValueCheckB :: TracePredicate +startAnAuctionValueCheckB = + valueAtAddress + (walletAddress Fixtures.userWallet) $ + \v -> (isNothing . find hasCatToken . V.flattenValue $ v) && (isNothing . find hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +completeAnAuctionValueCheckB :: TracePredicate +completeAnAuctionValueCheckB = + valueAtAddress + (walletAddress Fixtures.userWallet) $ + \v -> (Utils.one hasCatToken . V.flattenValue $ v) && (Utils.one hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +cancelAuctionDatumsCheckB :: TracePredicate +cancelAuctionDatumsCheckB = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (bundleNotOnAuction . Marketplace.mdBundles)) + where + bundleNotOnAuction = maybe False (Prelude.not . Marketplace.hasLotBundle) . + AssocMap.lookup Fixtures.bundleId + +cancelAnAuctionValueCheckB :: TracePredicate +cancelAnAuctionValueCheckB = + valueAtAddress + (walletAddress Fixtures.userWallet) $ + \v -> (Utils.one hasCatToken . V.flattenValue $ v) && (Utils.one hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +cancelAnAuctionBidReturningCheckB :: TracePredicate +cancelAnAuctionBidReturningCheckB = + walletFundsChange Fixtures.buyerWallet $ lovelaceValueOf 0 + +buyOnAuctionValueCheckB :: TracePredicate +buyOnAuctionValueCheckB = + valueAtAddress + (walletAddress Fixtures.buyerWallet) $ + \v -> (Utils.one hasCatToken . V.flattenValue $ v) && (Utils.one hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +marketplaceOperatorFeeCheck :: TracePredicate +marketplaceOperatorFeeCheck = + walletFundsChange Fixtures.ownerWallet $ toValue (Fixtures.marketplaceCreationFee + auctionFee - minAdaTxOut) + where + auctionFee = Lovelace $ Fixtures.roundedPercentage highestBid + +sellerProfitWithFeeCheck :: TracePredicate +sellerProfitWithFeeCheck = + walletFundsChange Fixtures.userWallet $ toValue (highestBidAda - Fixtures.marketplaceCreationFee - minAdaTxOut - auctionFee) + where + auctionFee = Lovelace $ Fixtures.roundedPercentage highestBid + highestBidAda = Lovelace highestBid + +marketplaceOperatorFeeCheckB :: TracePredicate +marketplaceOperatorFeeCheckB = + walletFundsChange Fixtures.ownerWallet $ toValue (totalMintingFee + totalBundlingFee + auctionFee - minAdaTxOut) + where + totalMintingFee = Fixtures.marketplaceCreationFee * 2 + totalBundlingFee = Fixtures.marketplaceCreationFee + auctionFee = Lovelace $ Fixtures.roundedPercentage highestBidB + +sellerProfitWithFeeCheckB :: TracePredicate +sellerProfitWithFeeCheckB = + walletFundsChange Fixtures.userWallet $ toValue (highestBidAda - totalMintingFee - totalBundlingFee - minAdaTxOut - auctionFee) + where + totalMintingFee = Fixtures.marketplaceCreationFee * 2 + totalBundlingFee = Fixtures.marketplaceCreationFee + auctionFee = Lovelace $ Fixtures.roundedPercentage highestBidB + highestBidAda = Lovelace highestBidB diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs new file mode 100644 index 000000000..bc0f4c43a --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Marketplace.Spec.Bundles + ( tests + , bundleTrace + , bundleErrorTrace + , unbundleTrace + , unbundleErrorTrace + ) where + +import Control.Lens ((^.), (^?)) +import Control.Monad (void) +import Data.Maybe (isNothing) +import Data.Proxy +import Data.Text (Text) +import Data.Void (Void) +import Ledger.Ada (toValue) +import Ledger.Index (minAdaTxOut) +import qualified Marketplace.Fixtures as Fixtures +import qualified Marketplace.Spec.Start as Start +import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Contract.Test +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Trace as Trace +import qualified PlutusTx.AssocMap as AssocMap +import Test.Tasty +import qualified Utils + +tests :: TestTree +tests = + testGroup + "Bundles" + [ + checkPredicateOptions + Fixtures.options + "Should create a bundle for two NFTs transforming Marketplace store" + (bundleDatumsCheck .&&. marketplaceOperatorFundsCheck) + (void bundleTrace), + checkPredicateOptions + Fixtures.options + "Should not create a bundle if NFTs are not minted" + errorCheckBundle + bundleErrorTrace, + checkPredicateOptions + Fixtures.options + "Should unbundle transforming Marketplace store" + unbundleDatumsCheck + unbundleTrace, + checkPredicateOptions + Fixtures.options + "Should not unbundle if bundle does not exist" + errorCheckUnbundle + unbundleErrorTrace + ] + +bundleUpParams :: Marketplace.BundleUpParams +bundleUpParams = Marketplace.BundleUpParams { + Marketplace.bupIpfsCids = Fixtures.cids, + Marketplace.bupName = Fixtures.bundleName, + Marketplace.bupDescription = Fixtures.bundleDescription, + Marketplace.bupCategory = Fixtures.bundleCategory + } + +bundleTrace :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +bundleTrace = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"createNft" h + Marketplace.CreateNftParams { + Marketplace.cnpIpfsCid = Fixtures.catTokenIpfsCid, + Marketplace.cnpNftName = Fixtures.catTokenName, + Marketplace.cnpNftDescription = Fixtures.catTokenDescription, + Marketplace.cnpNftCategory = Fixtures.catTokenCategory, + Marketplace.cnpRevealIssuer = False + } + _ <- Trace.waitNSlots 50 + _ <- Trace.callEndpoint @"createNft" h + Marketplace.CreateNftParams { + Marketplace.cnpIpfsCid = Fixtures.photoTokenIpfsCid, + Marketplace.cnpNftName = Fixtures.photoTokenName, + Marketplace.cnpNftDescription = Fixtures.photoTokenDescription, + Marketplace.cnpNftCategory = Fixtures.photoTokenCategory, + Marketplace.cnpRevealIssuer = False + } + _ <- Trace.waitNSlots 50 + _ <- Trace.callEndpoint @"bundleUp" h bundleUpParams + + _ <- Trace.waitNSlots 50 + pure h + +bundleErrorTrace :: Trace.EmulatorTrace () +bundleErrorTrace = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"bundleUp" h bundleUpParams + + _ <- Trace.waitNSlots 50 + pure () + +bundleDatumsCheck :: TracePredicate +bundleDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (containsBundle . Marketplace.mdBundles)) + where + containsBundle = maybe False checkBundle . + AssocMap.lookup Fixtures.bundleId + checkBundle b = maybe False containsNfts (b ^? Marketplace._nbTokens . Marketplace._NoLot) && + b ^. Marketplace._nbRecord == Fixtures.bundleInfo + containsNfts b = maybe False Fixtures.hasCatTokenRecord + (AssocMap.lookup Fixtures.catTokenIpfsCidHash b) && + maybe False Fixtures.hasPhotoTokenRecord + (AssocMap.lookup Fixtures.photoTokenIpfsCidHash b) + +errorCheckBundle :: TracePredicate +errorCheckBundle = Utils.assertCrError (Proxy @"bundleUp") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckUnbundle :: TracePredicate +errorCheckUnbundle = Utils.assertCrError (Proxy @"unbundle") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +unbundleTrace :: Trace.EmulatorTrace () +unbundleTrace = do + h <- bundleTrace + + _ <- Trace.callEndpoint @"unbundle" h $ Marketplace.UnbundleParams Fixtures.cids + + _ <- Trace.waitNSlots 50 + pure () + +unbundleErrorTrace :: Trace.EmulatorTrace () +unbundleErrorTrace = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"unbundle" h $ Marketplace.UnbundleParams Fixtures.cids + + _ <- Trace.waitNSlots 50 + pure () + +unbundleDatumsCheck :: TracePredicate +unbundleDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress $ Utils.checkOneDatum $ + \mp -> (containsNoBundle . Marketplace.mdBundles $ mp) && (containsNfts . Marketplace.mdSingletons $ mp) + where + containsNoBundle = isNothing . AssocMap.lookup Fixtures.bundleId + containsNfts store = maybe False (Fixtures.hasCatTokenRecord . Marketplace.nftRecord) + (AssocMap.lookup Fixtures.catTokenIpfsCidHash store) && + maybe False (Fixtures.hasPhotoTokenRecord . Marketplace.nftRecord) + (AssocMap.lookup Fixtures.photoTokenIpfsCidHash store) + +marketplaceOperatorFundsCheck :: TracePredicate +marketplaceOperatorFundsCheck = + walletFundsChange Fixtures.ownerWallet $ toValue (totalMintingFee + totalBundlingFee - minAdaTxOut) + where + totalBundlingFee = Fixtures.marketplaceCreationFee + totalMintingFee = Fixtures.marketplaceCreationFee * 2 diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/CreateNft.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/CreateNft.hs new file mode 100644 index 000000000..ea1a071cf --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/CreateNft.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Marketplace.Spec.CreateNft + ( tests + , createNftTrace + , createNftTrace' + ) where + +import Control.Lens (_2, (&), (.~), + (^.)) +import Control.Monad (void) +import Data.Maybe (isNothing) +import Data.Text (Text) +import Data.Void (Void) +import Ledger.Ada (toValue) +import Ledger.Index (minAdaTxOut) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures as Fixtures +import qualified Marketplace.Spec.Start as Start +import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Contract.Test +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Trace as Trace +import qualified PlutusTx.AssocMap as AssocMap +import Test.Tasty +import qualified Utils +import Wallet.Emulator.Wallet (walletAddress, + walletPubKeyHash) + +tests :: TestTree +tests = + testGroup + "createNft" + [ checkPredicateOptions + Fixtures.options + "Should mint NFT token into the user wallet and create the Marketplace entry hiding issuer" + (datumsCheck .&&. valueCheck .&&. marketplaceOperatorFundsCheck) + (void createNftTrace), + checkPredicateOptions + Fixtures.options + "Should mint NFT token into the user wallet and create the Marketplace entry revealing issuer" + (datumsCheck' .&&. valueCheck .&&. marketplaceOperatorFundsCheck) + createNftTrace' + ] + +createNftParams :: Marketplace.CreateNftParams +createNftParams = Marketplace.CreateNftParams { + Marketplace.cnpIpfsCid = Fixtures.catTokenIpfsCid, + Marketplace.cnpNftName = Fixtures.catTokenName, + Marketplace.cnpNftDescription = Fixtures.catTokenDescription, + Marketplace.cnpNftCategory = Fixtures.catTokenCategory, + Marketplace.cnpRevealIssuer = False + } + +createNftTrace :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +createNftTrace = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"createNft" h createNftParams + _ <- Trace.waitNSlots 50 + pure h + +createNftTrace' :: Trace.EmulatorTrace () +createNftTrace' = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"createNft" h $ createNftParams & Marketplace._cnpRevealIssuer .~ True + _ <- Trace.waitNSlots 50 + pure () + +datumsCheck :: TracePredicate +datumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (containsNft . Marketplace.mdSingletons)) + where + containsNft = maybe False (\t -> (t ^. Marketplace._nftLot & isNothing) && + (t ^. Marketplace._nftRecord . Marketplace._niIssuer & isNothing) && + (t ^. Marketplace._nftRecord & Fixtures.hasCatTokenRecord)) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +datumsCheck' :: TracePredicate +datumsCheck' = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (containsNft . Marketplace.mdSingletons)) + where + containsNft = maybe False (\t -> (t ^. Marketplace._nftLot & isNothing) && + t ^. Marketplace._nftRecord . Marketplace._niIssuer == Just (walletPubKeyHash Fixtures.userWallet) && + (t ^. Marketplace._nftRecord & Fixtures.hasCatTokenRecord)) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +valueCheck :: TracePredicate +valueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +marketplaceOperatorFundsCheck :: TracePredicate +marketplaceOperatorFundsCheck = + walletFundsChange Fixtures.ownerWallet $ toValue (Fixtures.marketplaceCreationFee - minAdaTxOut) diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs new file mode 100644 index 000000000..d81c1a9da --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Marketplace.Spec.Sale + ( tests + , openSaleTrace + , openSaleTrace' + , closeSaleTrace + , closeSaleTrace' + , buyItemTrace + , buyItemTrace' + ) where + +import Control.Lens (_2, _Left, (&), + (^.), (^?)) +import Control.Monad (void) +import Data.Foldable (find) +import Data.Maybe (isNothing) +import Data.Proxy +import Data.Text (Text) +import Data.Void (Void) +import Ledger.Ada (Ada (..), + lovelaceValueOf, + toValue) +import Ledger.Index (minAdaTxOut) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures as Fixtures +import qualified Marketplace.Spec.Bundles as Bundles +import qualified Marketplace.Spec.CreateNft as CreateNft +import qualified Marketplace.Spec.Start as Start +import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Contract.Test +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Contracts.Services.Sale as Sale +import qualified Plutus.Trace as Trace +import qualified PlutusTx.AssocMap as AssocMap +import Test.Tasty +import qualified Utils +import Wallet.Emulator.Wallet (walletAddress) + +tests :: TestTree +tests = + testGroup + "Sale" + [testGroup + "NFT singletons" + [ + checkPredicateOptions + Fixtures.options + "Should put on sale one NFT locking it in sale script & saving link" + (openSaleValueCheck .&&. openSaleDatumsCheck) + (void openSaleTrace), + checkPredicateOptions + Fixtures.options + "Should not put on sale if NFT does not exist" + errorCheckOpen + openSaleTrace', + checkPredicateOptions + Fixtures.options + "Should close sale and pay locked NFT back" + (closeSaleValueCheck .&&. completeSaleDatumsCheck) + closeSaleTrace, + checkPredicateOptions + Fixtures.options + "Should not close sale if it was not started" + errorCheckClose + closeSaleTrace', + checkPredicateOptions + Fixtures.options + "Should sell NFT and pay the token to buyer" + (buyItemValueCheck .&&. completeSaleDatumsCheck) + buyItemTrace, + checkPredicateOptions + Fixtures.options + "Should not sell NFT if it has no lot" + errorCheckBuyer + buyItemTrace', + checkPredicateOptions + Fixtures.options + "Should sell NFT and pay fee to marketplace operator" + (marketplaceOperatorFeeCheck .&&. sellersProfitWithPayingFeeCheck) + buyItemTrace + ], + testGroup + "NFT bundles" + [ + checkPredicateOptions + Fixtures.options + "Should put on sale NFT bundle locking bundle value in sale script & saving link" + (openSaleValueCheckB .&&. openSaleDatumsCheckB) + (void openSaleTraceB), + checkPredicateOptions + Fixtures.options + "Should not put on sale if bundle does not exist" + errorCheckOpen + openSaleTraceB', + checkPredicateOptions + Fixtures.options + "Should close sale and pay locked bundle value back" + (closeSaleValueCheckB .&&. completeSaleDatumsCheckB) + closeSaleTraceB, + checkPredicateOptions + Fixtures.options + "Should sell bundle and pay its value to buyer" + (buyItemValueCheckB .&&. completeSaleDatumsCheckB) + buyItemTraceB, + checkPredicateOptions + Fixtures.options + "Should sell bundle and pay fee to marketplace operator" + (marketplaceOperatorFeeCheckB .&&. sellersProfitWithPayingFeeCheckB) + buyItemTraceB + ]] + +-- \/\/\/ "NFT singletons" + +singletonNftPrice :: Integer +singletonNftPrice = 60 * Fixtures.oneAdaInLovelace + +openSaleParams :: Marketplace.OpenSaleParams +openSaleParams = Marketplace.OpenSaleParams { + Marketplace.ospItemId = Marketplace.UserNftId Fixtures.catTokenIpfsCid, + Marketplace.ospSalePrice = singletonNftPrice + } + +closeLotParams :: Marketplace.CloseLotParams +closeLotParams = Marketplace.CloseLotParams { + Marketplace.clpItemId = Marketplace.UserNftId Fixtures.catTokenIpfsCid + } + +openSaleTrace :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +openSaleTrace = do + h <- CreateNft.createNftTrace + + _ <- Trace.callEndpoint @"openSale" h openSaleParams + + _ <- Trace.waitNSlots 50 + pure h + +openSaleTrace' :: Trace.EmulatorTrace () +openSaleTrace' = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"openSale" h openSaleParams + + _ <- Trace.waitNSlots 50 + pure () + +closeSaleTrace :: Trace.EmulatorTrace () +closeSaleTrace = do + h <- openSaleTrace + + _ <- Trace.callEndpoint @"closeSale" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +closeSaleTrace' :: Trace.EmulatorTrace () +closeSaleTrace' = do + h <- CreateNft.createNftTrace + + _ <- Trace.callEndpoint @"closeSale" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +buyItemTrace :: Trace.EmulatorTrace () +buyItemTrace = do + _ <- openSaleTrace + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"buyItem" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +buyItemTrace' :: Trace.EmulatorTrace () +buyItemTrace' = do + _ <- CreateNft.createNftTrace + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"buyItem" h closeLotParams + + _ <- Trace.waitNSlots 50 + pure () + +openSaleDatumsCheck :: TracePredicate +openSaleDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (nftIsOnSale . Marketplace.mdSingletons)) + where + nftIsOnSale = maybe False (\t -> Marketplace.getSaleFromNFT t & fmap Sale.saleValue & + (== Just (Marketplace.nftValue Fixtures.catTokenIpfsCidBs t))) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +completeSaleDatumsCheck :: TracePredicate +completeSaleDatumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (nftNotOnSale . Marketplace.mdSingletons)) + where + nftNotOnSale = maybe False (isNothing . Marketplace.nftLot) . + AssocMap.lookup Fixtures.catTokenIpfsCidHash + +openSaleValueCheck :: TracePredicate +openSaleValueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (isNothing . find hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +closeSaleValueCheck :: TracePredicate +closeSaleValueCheck = + valueAtAddress + (walletAddress Fixtures.userWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +buyItemValueCheck :: TracePredicate +buyItemValueCheck = + valueAtAddress + (walletAddress Fixtures.buyerWallet) + (Utils.one hasNft . V.flattenValue) + where + hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + +errorCheckOpen :: TracePredicate +errorCheckOpen = Utils.assertCrError (Proxy @"openSale") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckClose :: TracePredicate +errorCheckClose = Utils.assertCrError (Proxy @"closeSale") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckBuyer :: TracePredicate +errorCheckBuyer = Utils.assertCrError (Proxy @"buyItem") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) + + +-- \/\/\/ "NFT bundles" + +bundleNftPrice :: Integer +bundleNftPrice = 85 * Fixtures.oneAdaInLovelace + +openSaleParamsB :: Marketplace.OpenSaleParams +openSaleParamsB = Marketplace.OpenSaleParams { + Marketplace.ospItemId = Marketplace.UserBundleId Fixtures.cids, + Marketplace.ospSalePrice = bundleNftPrice + } + +closeLotParamsB :: Marketplace.CloseLotParams +closeLotParamsB = Marketplace.CloseLotParams { + Marketplace.clpItemId = Marketplace.UserBundleId Fixtures.cids + } + +openSaleTraceB :: Trace.EmulatorTrace (Trace.ContractHandle (ContractResponse String Text Marketplace.UserContractState) Marketplace.MarketplaceUserSchema Void) +openSaleTraceB = do + h <- Bundles.bundleTrace + + _ <- Trace.callEndpoint @"openSale" h openSaleParamsB + + _ <- Trace.waitNSlots 50 + pure h + +openSaleTraceB' :: Trace.EmulatorTrace () +openSaleTraceB' = do + _ <- Start.startTrace + h <- Trace.activateContractWallet Fixtures.userWallet $ Marketplace.userEndpoints Fixtures.marketplace + + _ <- Trace.callEndpoint @"openSale" h openSaleParamsB + + _ <- Trace.waitNSlots 50 + pure () + +closeSaleTraceB :: Trace.EmulatorTrace () +closeSaleTraceB = do + h <- openSaleTraceB + + _ <- Trace.callEndpoint @"closeSale" h closeLotParamsB + + _ <- Trace.waitNSlots 50 + pure () + +buyItemTraceB :: Trace.EmulatorTrace () +buyItemTraceB = do + _ <- openSaleTraceB + + h <- Trace.activateContractWallet Fixtures.buyerWallet $ Marketplace.userEndpoints Fixtures.marketplace + _ <- Trace.callEndpoint @"buyItem" h closeLotParamsB + + _ <- Trace.waitNSlots 50 + pure () + +openSaleDatumsCheckB :: TracePredicate +openSaleDatumsCheckB = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (bundleIsOnSale . Marketplace.mdBundles)) + where + bundleIsOnSale = maybe False (\b -> Marketplace.getSaleFromBundle b & fmap Sale.saleValue & + (== Just (Marketplace.bundleValue AssocMap.empty b))) . + AssocMap.lookup Fixtures.bundleId + +completeSaleDatumsCheckB :: TracePredicate +completeSaleDatumsCheckB = + dataAtAddress + Fixtures.marketplaceAddress + (Utils.checkOneDatum (bundleNotOnSale . Marketplace.mdBundles)) + where + bundleNotOnSale = maybe False (Prelude.not . Marketplace.hasLotBundle) . + AssocMap.lookup Fixtures.bundleId + +openSaleValueCheckB :: TracePredicate +openSaleValueCheckB = + valueAtAddress + (walletAddress Fixtures.userWallet) $ + \v -> (isNothing . find hasCatToken . V.flattenValue $ v) && (isNothing . find hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +closeSaleValueCheckB :: TracePredicate +closeSaleValueCheckB = + valueAtAddress + (walletAddress Fixtures.userWallet) $ + \v -> (Utils.one hasCatToken . V.flattenValue $ v) && (Utils.one hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +buyItemValueCheckB :: TracePredicate +buyItemValueCheckB = + valueAtAddress + (walletAddress Fixtures.buyerWallet) $ + \v -> (Utils.one hasCatToken . V.flattenValue $ v) && (Utils.one hasPhotoToken . V.flattenValue $ v) + where + hasCatToken v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs + hasPhotoToken v = (v ^. _2 & V.unTokenName) == Fixtures.photoTokenIpfsCidBs + +marketplaceOperatorFeeCheck :: TracePredicate +marketplaceOperatorFeeCheck = + walletFundsChange Fixtures.ownerWallet $ toValue (Fixtures.marketplaceCreationFee + saleFee - minAdaTxOut) + where + saleFee = Lovelace $ Fixtures.roundedPercentage singletonNftPrice + +sellersProfitWithPayingFeeCheck :: TracePredicate +sellersProfitWithPayingFeeCheck = + walletFundsChange Fixtures.userWallet $ toValue (nftPriceAda - saleFee - Fixtures.marketplaceCreationFee - minAdaTxOut) + where + nftPriceAda = Lovelace singletonNftPrice + saleFee = Lovelace $ Fixtures.roundedPercentage singletonNftPrice + +marketplaceOperatorFeeCheckB :: TracePredicate +marketplaceOperatorFeeCheckB = + walletFundsChange Fixtures.ownerWallet $ toValue (totalMintingFee + totalBundlingFee + saleFee - minAdaTxOut) + where + totalMintingFee = Fixtures.marketplaceCreationFee * 2 + totalBundlingFee = Fixtures.marketplaceCreationFee + saleFee = Lovelace $ Fixtures.roundedPercentage bundleNftPrice + +sellersProfitWithPayingFeeCheckB :: TracePredicate +sellersProfitWithPayingFeeCheckB = + walletFundsChange Fixtures.userWallet $ toValue (bundlePriceAda - totalMintingFee - totalBundlingFee - minAdaTxOut - saleFee) + where + totalMintingFee = Fixtures.marketplaceCreationFee * 2 + totalBundlingFee = Fixtures.marketplaceCreationFee + saleFee = Lovelace $ Fixtures.roundedPercentage bundleNftPrice + bundlePriceAda = Lovelace bundleNftPrice diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Start.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Start.hs new file mode 100644 index 000000000..c730b4578 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Start.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Marketplace.Spec.Start + ( tests, startTrace + ) where + +import Control.Monad (void) +import Data.Text (Text) +import Ledger.Ada (Ada (..), + toValue) +import Ledger.Index (minAdaTxOut) +import qualified Ledger.Value as V +import qualified Marketplace.Fixtures as Fixtures +import Plutus.Abstract.Percentage (getPercentage) +import Plutus.Contract (Contract) +import Plutus.Contract.Test +import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace +import Plutus.Contracts.NftMarketplace.OffChain.Owner (StartMarketplaceParams (..)) +import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace +import qualified Plutus.Trace as Trace +import qualified PlutusTx.AssocMap as AssocMap +import Test.Tasty + +tests :: TestTree +tests = + testGroup + "start" + [ checkPredicateOptions + Fixtures.options + "Should start a new marketplace with empty store" + (datumsCheck .&&. marketplaceOpenedWithMinAdaTxOut .&&. marketplaceOperatorPayedMinAdaTxOut) + startTrace + ] + +startTrace :: Trace.EmulatorTrace () +startTrace = do + h <- Trace.activateContractWallet Fixtures.ownerWallet Marketplace.ownerEndpoints + _ <- Trace.callEndpoint @"start" h startMarketplaceParams + _ <- Trace.waitNSlots 50 + pure () + +startMarketplaceParams :: StartMarketplaceParams +startMarketplaceParams = StartMarketplaceParams { + creationFee = getLovelace $ Fixtures.marketplaceCreationFee, + saleFee = getPercentage Fixtures.percentage +} + +startContract :: + Contract () Marketplace.MarketplaceOwnerSchema Text Marketplace.Marketplace +startContract = Marketplace.start startMarketplaceParams + +datumsCheck :: TracePredicate +datumsCheck = + dataAtAddress + Fixtures.marketplaceAddress + (== [Marketplace.MarketplaceDatum AssocMap.empty AssocMap.empty]) + +marketplaceOpenedWithMinAdaTxOut :: TracePredicate +marketplaceOpenedWithMinAdaTxOut = + valueAtAddress Fixtures.marketplaceAddress (toValue minAdaTxOut ==) + +marketplaceOperatorPayedMinAdaTxOut :: TracePredicate +marketplaceOperatorPayedMinAdaTxOut = + walletFundsChange Fixtures.ownerWallet $ toValue (- minAdaTxOut) diff --git a/MetaLamp/nft-marketplace/test/Utils.hs b/MetaLamp/nft-marketplace/test/Utils.hs new file mode 100644 index 000000000..ee68fe1c3 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Utils.hs @@ -0,0 +1,4 @@ +module Utils (module Export) where + +import Utils.Data as Export +import Utils.Trace as Export diff --git a/MetaLamp/nft-marketplace/test/Utils/Data.hs b/MetaLamp/nft-marketplace/test/Utils/Data.hs new file mode 100644 index 000000000..522732ee9 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Utils/Data.hs @@ -0,0 +1,13 @@ +module Utils.Data where + +import Ledger (Address, pubKeyHash) +import Plutus.V1.Ledger.Crypto (PubKeyHash) + +one :: (a -> Bool) -> [a] -> Bool +one f = foldr reducer False + where + reducer cur acc = if acc then not . f $ cur else f cur + +checkOneDatum :: (d -> Bool) -> [d] -> Bool +checkOneDatum check [d] = check d +checkOneDatum _ _ = False diff --git a/MetaLamp/nft-marketplace/test/Utils/Trace.hs b/MetaLamp/nft-marketplace/test/Utils/Trace.hs new file mode 100644 index 000000000..ca280a9f6 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Utils/Trace.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Utils.Trace where + + +import Control.Lens ((^?)) +import Data.Maybe (isJust) +import Data.Monoid (Last (..)) +import GHC.TypeLits (KnownSymbol) +import Plutus.Abstract.ContractResponse (ContractResponse, + ContractState (..)) +import Plutus.Abstract.RemoteData (RemoteData (..)) +import qualified Plutus.Abstract.RemoteData as RD +import qualified Plutus.Contract as C +import Plutus.Contract.Test (TracePredicate, + assertAccumState) +import qualified Plutus.Trace.Emulator as Trace + +assertCrError :: forall contract e r s err a proxy l. (Show r, Show e, C.IsContract contract, KnownSymbol l) => + proxy l -> + contract (ContractResponse String e r) s err a + -> Trace.ContractInstanceTag + -> TracePredicate +assertCrError _p c tag = assertAccumState c tag isError "Expected contract error but there was none" + where + isError :: ContractResponse String e r -> Bool + isError (Last (Just (ContractState _ rd))) = RD.isFailure rd