From 740658c5b6f4ac72a854d41bc9129eacd6800235 Mon Sep 17 00:00:00 2001 From: Amir Rad <44954417+amirmrad@users.noreply.github.com> Date: Mon, 30 Dec 2024 12:39:58 +0000 Subject: [PATCH] Offchain implementation of SmartToken contracts (#13) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Initial nix and server boilerplate * Offchain protocol params and directory * Programmable Transfer * Module refactoring, rebase & formatting * Add endpoint for deploying protocol params * Add loadEnv * Fill directory derivation and redeemers * Add test * Programmable token issue tx builder * Seizing tx builder * Add initDirectoryTx + test (failing in lib/SmartTokens/LinkedList/Common.hs:214) * Initial builders for transfer contracts * Fix 'initDirectoryTx' * Make a single endpoint for deployment * Add some query endpoints * Better type for query result * Wst.Offchain.Endpoints.Env -> Wst.Offchain.Env, rename to OperatorEnv * Move all env-like types to Wst.Offchain.Env * Use classes for environment bits * Use Env in DirectorySet, move Query module around * Add InsertNodeArgs for insertDirectoryNode * Issue transfer logic builder * Add TransferLogicEnv * Fix insert directory node test * Add transferStablecoins tx builder * Add seizeStablecoins tx builder * Add issueProgrammableTokenTx endpoint * Export issueProgrammableTokenTx * issueProgrammableTokenTx with always yields validator * Add query for programmable logic UTxOs * CLI command parser * CLI setup * Load operator files * Add some documentation * Link to linked list * Typo * Add server implementation, better handling of Environment * WIP issue and transfer smart tokens endpoints * Smart token transfer unit test flow * Sezing endpoint/unit test & fixes to transfer * Error handling for blacklisted node * Fix alwaysSucceeds script * Update hash --------- Co-authored-by: Jann Müller --- README.md | 56 ++- cabal.project | 14 + flake.lock | 82 +--- flake.nix | 7 +- nix/project.nix | 3 +- src/exe/wst-poc-cli/Main.hs | 6 + src/exe/wst-poc/Main.hs | 6 - src/lib/SmartTokens/CodeLens.hs | 25 ++ src/lib/SmartTokens/Contracts/AlwaysYields.hs | 13 + .../Contracts/ExampleTransferLogic.hs | 36 +- src/lib/SmartTokens/Contracts/Issuance.hs | 38 +- .../Contracts/ProgrammableLogicBase.hs | 76 +++- src/lib/SmartTokens/Core/Scripts.hs | 24 -- src/lib/SmartTokens/LinkedList/Common.hs | 121 ++---- .../SmartTokens/LinkedList/MintDirectory.hs | 67 ++- src/lib/SmartTokens/Types/Constants.hs | 21 +- src/lib/SmartTokens/Types/PTokenDirectory.hs | 63 ++- src/lib/SmartTokens/Types/ProtocolParams.hs | 49 ++- src/lib/Wst/App.hs | 44 ++ src/lib/Wst/AppError.hs | 17 + src/lib/Wst/Cli.hs | 50 ++- src/lib/Wst/Cli/Command.hs | 72 ++++ src/lib/Wst/Client.hs | 38 ++ src/lib/Wst/Offchain.hs | 2 +- src/lib/Wst/Offchain/BuildTx/Blacklist.hs | 2 + src/lib/Wst/Offchain/BuildTx/Common.hs | 0 src/lib/Wst/Offchain/BuildTx/DirectorySet.hs | 141 +++++++ .../Wst/Offchain/BuildTx/ExampleTransfer.hs | 39 ++ src/lib/Wst/Offchain/BuildTx/LinkedList.hs | 18 + .../Wst/Offchain/BuildTx/ProgrammableLogic.hs | 250 +++++++++++ .../Wst/Offchain/BuildTx/ProtocolParams.hs | 61 +++ src/lib/Wst/Offchain/BuildTx/TransferLogic.hs | 342 +++++++++++++++ src/lib/Wst/Offchain/Endpoints/Deployment.hs | 196 +++++++++ src/lib/Wst/Offchain/Env.hs | 391 ++++++++++++++++++ src/lib/Wst/Offchain/Query.hs | 107 +++++ src/lib/Wst/Offchain/Scripts.hs | 135 ++++++ src/lib/Wst/Onchain.hs | 2 +- src/lib/Wst/Server.hs | 65 ++- src/lib/Wst/Server/Endpoints.hs | 31 ++ src/lib/Wst/Server/Types.hs | 58 +++ src/test/Spec.hs | 8 + src/test/Wst/Test/Env.hs | 60 +++ src/test/Wst/Test/UnitTest.hs | 298 +++++++++++++ src/wst-poc.cabal | 165 ++++++-- 44 files changed, 2997 insertions(+), 302 deletions(-) create mode 100644 src/exe/wst-poc-cli/Main.hs delete mode 100644 src/exe/wst-poc/Main.hs create mode 100644 src/lib/SmartTokens/CodeLens.hs create mode 100644 src/lib/SmartTokens/Contracts/AlwaysYields.hs create mode 100644 src/lib/Wst/App.hs create mode 100644 src/lib/Wst/AppError.hs create mode 100644 src/lib/Wst/Cli/Command.hs create mode 100644 src/lib/Wst/Client.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/Blacklist.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/Common.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/DirectorySet.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/ExampleTransfer.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/LinkedList.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs create mode 100644 src/lib/Wst/Offchain/BuildTx/TransferLogic.hs create mode 100644 src/lib/Wst/Offchain/Endpoints/Deployment.hs create mode 100644 src/lib/Wst/Offchain/Env.hs create mode 100644 src/lib/Wst/Offchain/Query.hs create mode 100644 src/lib/Wst/Offchain/Scripts.hs create mode 100644 src/lib/Wst/Server/Endpoints.hs create mode 100644 src/lib/Wst/Server/Types.hs create mode 100644 src/test/Spec.hs create mode 100644 src/test/Wst/Test/Env.hs create mode 100644 src/test/Wst/Test/UnitTest.hs diff --git a/README.md b/README.md index 4c55ab2..513ba3a 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,60 @@ This is a proof-of-concept for a regulated stablecoin. It is NOT a finished product. +# Overview + +The POC is based on [CIP-0143](https://github.com/colll78/CIPs/blob/patch-3/CIP-0143/README.md), instantiated with a programmable logic that checks whether the target address is blacklisted before allowing a transfer of the programmable token from one owner to another. + +# Architecture + +The system is designed so that all actions except the initial deployment of the programmable logic UTxOs can be performed through a web UI with browser-based wallets. The REST API therefore exposes a number of endpoints that produce fully-balanced-but-not-signed transactions. The intention is for the caller (web UI) to sign the transactions with the web-based wallet and submit them to the network. The backend uses blockfrost to query the blockchain. As a result, the server is pretty light-weight and does not even need its own database or a full cardano node. + +# Usage + +There is a CLI tool `wst-poc-cli` that performs the initial deployment of the system and runs the REST server. A signing key file is needed for the initial deployment but not for the operation of the server. A blockfrost token is needed for both the initial deployment. + +(TO DO - document CLI operations) + +# FAQs + +## How is this system different from Djed? + +Djed is an algorithmic stablecoin that is backed by Ada. In Djed we keep the entire reserves of the stablecoin in a UTxO that is controlled by the Djed contract. Every user of Djed can verify that the reserves exist and that there is enough Ada to pay out all Djed holders. + +This POC implements a _fiat-backed stablecoin_. This means that the reserves exist in a bank account outside of the blockchain, and we have to trust the issuer of the stablecoin that every token that's been issued on-chain is backed by one USD in the bank account. + +From a technical perspective, not having to manage the reserve on-chain makes the design of this POC somewhat simpler: We don't need to maintain a global state (the Djed UTxO) that all orders have to synchronise with. The challenge in this POC lies in the programmable token logic. + +## How does the system scale? + +The core idea of the regulated stablecoin is to run a check every time the owner of some amount of regulated tokens changes. This check is performed by the _transfer logic script_, a plutus program that consults a list of sanctioned addresses to ensure that the receiving address is not on it. + +The list of sanctioned addresses is the only data structure that (a) needs to be read from by every transaction of the transfer logic script and (b) gets changed regularly during the operation of the stablecoin. + +All other factors (number of scripts, script budget, max. number of transfer checks per transaction and so forth) are fixed and do not depend on the number of users. + +It is important to note that the list of sanctioned addresses scales in space (number of UTxOs), but working with the data structure is done in constant time due to the way the data is laid out. + +There is also no risk of UTxO congestion as the "system outputs" are used as reference inputs and not spent by user-to-user transfers. Each user-to-user transfer is processed independently. + +### Sanctioned Addresses + +The list of sanctioned addresses is stored on-chain as a [_linked list_](https://github.com/Anastasia-Labs/plutarch-linked-list). This means that each entry (address) in the list is represented as a single transaction output that includes the address itself as well as a pointer to the next address in lexicographical order. + +When checking a transfer, the transfer logic script is provided with a single reference input containing the relevant entry in the ordered linked list. + +The transfer transaction does not spend the linked list output, therefore the same linked list output can be used by many transactions in the same block and across multiple blocks. + +#### How many sanctioned addresses are there? + +Publicly available data on Tether (the largest fiat stablecoin) indicates that Tether has a total of [1990 sanctioned addresses](https://dune.com/phabc/usdt---banned-addresses), out of [109 million on-chain wallets](https://tether.io/news/how-many-usdt-on-chain-holders-are-there/) (Dec. 2024). This suggests that about 0.002 percent of addresses need to be blacklisted. + +If our system achieved the scale of Tether then we would need about 1200 UTxOs to store the linked list. At current Ada prices this would amount to 1800 USD in min Ada UTxO deposits, an amount that will be refunded in its entirety when the linked list is deleted. + +USDC, another fiat-stablecoin, currently has [264 blacklisted addresses](https://bloxy.info/txs/events_sc/0xa0b86991c6218b36c1d19d4a2e9eb0ce3606eb48?signature_id=257159) and 3m users, with a blacklist ratio of about 0.009 percent. + # Contributing -Bug reports and contributions are welcome! \ No newline at end of file +Run the tests with `cabal test all`. + +Bug reports and contributions are welcome! diff --git a/cabal.project b/cabal.project index 57f4e62..22bab83 100644 --- a/cabal.project +++ b/cabal.project @@ -38,3 +38,17 @@ source-repository-package tag: 650a3435f8efbd4bf36e58768fac266ba5beede4 subdir: src/plutarch-onchain-lib + +source-repository-package + type: git + location: https://github.com/j-mueller/sc-tools + tag: e2759559324e172f12b11ab815323c48ed8922b0 + subdir: + src/devnet + src/blockfrost + src/coin-selection + src/mockchain + src/optics + src/wallet + src/base + src/node-client diff --git a/flake.lock b/flake.lock index d4dd992..e7ae139 100644 --- a/flake.lock +++ b/flake.lock @@ -11,7 +11,7 @@ "type": "github" }, "original": { - "owner": "input-output-hk", + "owner": "IntersectMBO", "ref": "repo", "repo": "cardano-haskell-packages", "type": "github" @@ -100,23 +100,6 @@ "type": "github" } }, - "blst_3": { - "flake": false, - "locked": { - "lastModified": 1691598027, - "narHash": "sha256-oqljy+ZXJAXEB/fJtmB8rlAr4UXM+Z2OkDa20gpILNA=", - "owner": "supranational", - "repo": "blst", - "rev": "3dd0f804b1819e5d03fb22ca2e6fac105932043a", - "type": "github" - }, - "original": { - "owner": "supranational", - "ref": "v0.3.11", - "repo": "blst", - "type": "github" - } - }, "cabal-32": { "flake": false, "locked": { @@ -1326,37 +1309,13 @@ "inputs": { "blst": "blst_2", "nixpkgs": [ + "plutarch", "haskell-nix", "nixpkgs" ], "secp256k1": "secp256k1_2", "sodium": "sodium_2" }, - "locked": { - "lastModified": 1732287300, - "narHash": "sha256-lURsE6HdJX0alscWhbzCWyLRK8GpAgKuXeIgX31Kfqg=", - "owner": "input-output-hk", - "repo": "iohk-nix", - "rev": "262cb2aec2ddd914124bab90b06fe24a1a74d02c", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "iohk-nix", - "type": "github" - } - }, - "iohk-nix_3": { - "inputs": { - "blst": "blst_3", - "nixpkgs": [ - "plutarch", - "haskell-nix", - "nixpkgs" - ], - "secp256k1": "secp256k1_3", - "sodium": "sodium_3" - }, "locked": { "lastModified": 1730297014, "narHash": "sha256-n3f1iAmltKnorHWx7FrdbGIF/FmEG8SsZshS16vnpz0=", @@ -2060,7 +2019,7 @@ "flake-parts": "flake-parts_2", "haskell-nix": "haskell-nix_2", "hercules-ci-effects": "hercules-ci-effects", - "iohk-nix": "iohk-nix_3", + "iohk-nix": "iohk-nix_2", "nixpkgs": "nixpkgs_7", "pre-commit-hooks": "pre-commit-hooks" }, @@ -2127,7 +2086,6 @@ "hackage": "hackage", "haskell-nix": "haskell-nix", "iogx": "iogx", - "iohk-nix": "iohk-nix_2", "nixpkgs": [ "haskell-nix", "nixpkgs" @@ -2169,23 +2127,6 @@ "type": "github" } }, - "secp256k1_3": { - "flake": false, - "locked": { - "lastModified": 1683999695, - "narHash": "sha256-9nJJVENMXjXEJZzw8DHzin1DkFkF8h9m/c6PuM7Uk4s=", - "owner": "bitcoin-core", - "repo": "secp256k1", - "rev": "acf5c55ae6a94e5ca847e07def40427547876101", - "type": "github" - }, - "original": { - "owner": "bitcoin-core", - "ref": "v0.3.2", - "repo": "secp256k1", - "type": "github" - } - }, "sodium": { "flake": false, "locked": { @@ -2220,23 +2161,6 @@ "type": "github" } }, - "sodium_3": { - "flake": false, - "locked": { - "lastModified": 1675156279, - "narHash": "sha256-0uRcN5gvMwO7MCXVYnoqG/OmeBFi8qRVnDWJLnBb9+Y=", - "owner": "input-output-hk", - "repo": "libsodium", - "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "libsodium", - "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", - "type": "github" - } - }, "sphinxcontrib-haddock": { "flake": false, "locked": { diff --git a/flake.nix b/flake.nix index 2b8fd75..3381269 100644 --- a/flake.nix +++ b/flake.nix @@ -11,8 +11,9 @@ }; nixpkgs.follows = "haskell-nix/nixpkgs"; - iohk-nix.url = "github:input-output-hk/iohk-nix"; - iohk-nix.inputs.nixpkgs.follows = "haskell-nix/nixpkgs"; + + # iohk-nix.url = "github:input-output-hk/iohk-nix"; + # iohk-nix.inputs.nixpkgs.follows = "haskell-nix/nixpkgs"; hackage = { url = "github:input-output-hk/hackage.nix"; @@ -20,7 +21,7 @@ }; CHaP = { - url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; + url = "github:IntersectMBO/cardano-haskell-packages?ref=repo"; flake = false; }; diff --git a/nix/project.nix b/nix/project.nix index cebdf5e..ae9198e 100644 --- a/nix/project.nix +++ b/nix/project.nix @@ -2,6 +2,7 @@ let sha256map = { + "https://github.com/j-mueller/sc-tools"."e2759559324e172f12b11ab815323c48ed8922b0" = "sha256-NHX+Euys+jBwKdTRJhK4XZLOOxQ+lf45T0BOroMF1m4="; "https://github.com/colll78/plutarch-plutus"."b2379767c7f1c70acf28206bf922f128adc02f28" = "sha256-mhuW2CHxnc6FDWuMcjW/51PKuPOdYc4yxz+W5RmlQew="; "https://github.com/input-output-hk/catalyst-onchain-libs"."650a3435f8efbd4bf36e58768fac266ba5beede4" = "sha256-NUh+l97+eO27Ppd8Bx0yMl0E5EV+p7+7GuFun1B8gRc="; }; @@ -13,7 +14,7 @@ let src = ../.; name = "smart-tokens-plutarch"; compiler-nix-name = "ghc966"; - index-state = "2024-10-16T00:00:00Z"; + # index-state = "2024-10-16T00:00:00Z"; inputMap = { "https://chap.intersectmbo.org/" = inputs.CHaP; }; diff --git a/src/exe/wst-poc-cli/Main.hs b/src/exe/wst-poc-cli/Main.hs new file mode 100644 index 0000000..7440fd1 --- /dev/null +++ b/src/exe/wst-poc-cli/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Wst.Cli qualified + +main :: IO () +main = Wst.Cli.runMain diff --git a/src/exe/wst-poc/Main.hs b/src/exe/wst-poc/Main.hs deleted file mode 100644 index a1246b9..0000000 --- a/src/exe/wst-poc/Main.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import qualified Wst.Cli - -main :: IO () -main = Wst.Cli.runMain \ No newline at end of file diff --git a/src/lib/SmartTokens/CodeLens.hs b/src/lib/SmartTokens/CodeLens.hs new file mode 100644 index 0000000..6ca8744 --- /dev/null +++ b/src/lib/SmartTokens/CodeLens.hs @@ -0,0 +1,25 @@ +module SmartTokens.CodeLens( + _printTerm +) where + +import Data.Text qualified as T +import GHC.Stack (HasCallStack) +import Plutarch (ClosedTerm) +import Plutarch.Internal qualified as PI +import Plutarch.Internal.Other (printScript) + +-- TODO: Move to catalyst-libs project + +-- _printTerm (communicated by Philip) just print some term as string. The term we want to print is +-- @ +-- _term :: forall {s :: S}. Term s PBlacklistNode +-- _term = unsafeEvalTerm NoTracing (pconstant $ BlackListNode { key = "a", next = "b" }) +-- @ +-- Below, we inline the term and have it in a code lens. You can even run the code lens via Haskell +-- language server. The lens will then replace the string starting with "program ..." with exactly +-- the same string. +-- +-- >>> _printTerm (pconstantData $ BlacklistNode { blnKey = "a hi", blnNext = "a" }) +-- "program 1.0.0 (List [B #61206869, B #61])" +_printTerm :: HasCallStack => ClosedTerm a -> String +_printTerm term = printScript $ either (error . T.unpack) id $ PI.compile PI.NoTracing term diff --git a/src/lib/SmartTokens/Contracts/AlwaysYields.hs b/src/lib/SmartTokens/Contracts/AlwaysYields.hs new file mode 100644 index 0000000..c900708 --- /dev/null +++ b/src/lib/SmartTokens/Contracts/AlwaysYields.hs @@ -0,0 +1,13 @@ +{-| Plutus V3 script that always yields, ignoring its argument +-} +module SmartTokens.Contracts.AlwaysYields( + palwaysSucceed +) where + +import Plutarch.LedgerApi.V3 (PScriptContext) +import Plutarch.Prelude (ClosedTerm, PUnit, pconstant, plam, (:-->)) + +{-| Validator that always succeeds +-} +palwaysSucceed :: ClosedTerm (PScriptContext :--> PUnit) +palwaysSucceed = plam (const $ pconstant ()) diff --git a/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs b/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs index 65ef3f5..aa8551d 100644 --- a/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs +++ b/src/lib/SmartTokens/Contracts/ExampleTransferLogic.hs @@ -3,9 +3,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + module SmartTokens.Contracts.ExampleTransferLogic ( mkPermissionedTransfer, mkFreezeAndSeizeTransfer, + BlacklistProof (..), ) where import Plutarch.LedgerApi.V3 @@ -26,7 +30,26 @@ import Plutarch.Core.Utils pvalidateConditions ) import Plutarch.Unsafe ( punsafeCoerce ) import SmartTokens.Types.PTokenDirectory ( PBlacklistNode, pletFieldsBlacklistNode) - +import qualified PlutusTx +import Plutarch.DataRepr (DerivePConstantViaData (..)) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) + +-- >>> _printTerm $ unsafeEvalTerm NoTracing (pconstant $ NonmembershipProof 1) +-- "program 1.0.0 (Constr 0 [I 1])" +data BlacklistProof + = NonmembershipProof Integer + deriving stock (Show, Eq, Generic) + +PlutusTx.makeIsDataIndexed ''BlacklistProof + [('NonmembershipProof, 0)] + +deriving via + (DerivePConstantViaData BlacklistProof PBlacklistProof) + instance + (PConstantDecl BlacklistProof) + +-- >>> _printTerm $ unsafeEvalTerm NoTracing (mkRecordConstr PNonmembershipProof ( #nodeIdx .= pdata (pconstant 1))) +-- "program 1.0.0 (Constr 0 [I 1])" data PBlacklistProof (s :: S) = PNonmembershipProof ( Term @@ -37,11 +60,14 @@ data PBlacklistProof (s :: S) ) ) deriving stock (Generic) - deriving anyclass (PlutusType, PIsData, PEq) + deriving anyclass (PlutusType, PIsData, PEq, PShow) instance DerivePlutusType PBlacklistProof where type DPTStrat _ = PlutusTypeData +instance PUnsafeLiftDecl PBlacklistProof where + type PLifted PBlacklistProof = BlacklistProof + {-| The 'mkPermissionedTransfer' is a transfer logic script that enforces that all transactions which spend the associated programmable tokens must be signed by the specified permissioned credential. @@ -86,7 +112,7 @@ mkPermissionedTransfer = plam $ \permissionedCred ctx -> first node and lexographically less than the key of the second node (and thus if it was in the blacklist those two nodes would not be adjacent). - Confirms the legitimacy of both directory entries by checking the presence of the directory node currency symbol. - - For 'PNonmembershipProofTail': + - For 'PNonmembershipProofTail': FIXME: outdated - Ensures that the witness key is greater than the tail node key in the blacklist. - Confirms the legitimacy of the directory entry by checking the presence of the directory node currency symbol. @@ -113,7 +139,7 @@ pvalidateWitnesses = phoistAcyclic $ plam $ \blacklistNodeCS proofs refInputs wi -- the currency symbol is not in the blacklist nodeKey #< witnessKey , witnessKey #< nodeNext #|| nodeNext #== pconstant "" - -- both directory entries are legitimate, this is proven by the + -- directory entries are legitimate, this is proven by the -- presence of the directory node currency symbol. , phasDataCS # blacklistNodeCS # pfromData prevNodeUTxOF.value ] @@ -162,4 +188,4 @@ mkFreezeAndSeizeTransfer = plam $ \blacklistNodeCS ctx -> P.do pvalidateConditions [ pisRewarding ctxF.scriptInfo , pvalidateWitnesses # blacklistNodeCS # red # infoF.referenceInputs # txWitnesses - ] \ No newline at end of file + ] diff --git a/src/lib/SmartTokens/Contracts/Issuance.hs b/src/lib/SmartTokens/Contracts/Issuance.hs index 517cf52..040efa7 100644 --- a/src/lib/SmartTokens/Contracts/Issuance.hs +++ b/src/lib/SmartTokens/Contracts/Issuance.hs @@ -1,19 +1,31 @@ -{-# LANGUAGE QualifiedDo #-} {-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE UndecidableInstances #-} + module SmartTokens.Contracts.Issuance ( mkProgrammableLogicMinting, + SmartTokenMintingAction (..), ) where -import Plutarch.LedgerApi.V3 (PCredential, PScriptContext, PScriptInfo(PMintingScript)) +import Plutarch.Builtin (pdataImpl, pfromDataImpl) +import Plutarch.Core.Utils (pand'List, pheadSingleton, ptryLookupValue, + pvalidateConditions, (#>)) +import Plutarch.Internal.PlutusType (PlutusType (pcon', pmatch')) +import Plutarch.LedgerApi.V3 (PCredential, PScriptContext, + PScriptInfo (PMintingScript)) +import Plutarch.LedgerApi.Value (PCurrencySymbol, pvalueOf) import Plutarch.Monadic qualified as P import Plutarch.Prelude -import Plutarch.Builtin (pfromDataImpl, pdataImpl) -import Plutarch.LedgerApi.Value (PCurrencySymbol, pvalueOf) -import Plutarch.Core.Utils (ptryLookupValue, pheadSingleton, pand'List, (#>), pvalidateConditions) import Plutarch.Unsafe (punsafeCoerce) -import Plutarch.Internal.PlutusType (PlutusType(pcon', pmatch')) ---import SmartTokens.Types.PTokenDirectory (PDirectorySetNode) +import PlutusTx qualified + +data SmartTokenMintingAction = RegisterPToken | MintPToken + deriving stock (Show, Eq, Generic) + +instance PlutusTx.ToData SmartTokenMintingAction where + toBuiltinData RegisterPToken = PlutusTx.dataToBuiltinData (PlutusTx.I 0) + toBuiltinData MintPToken = PlutusTx.dataToBuiltinData (PlutusTx.I 1) data PSmartTokenMintingAction (s :: S) = PRegisterPToken | PMintPToken @@ -27,7 +39,7 @@ instance PlutusType PSmartTokenMintingAction where pcon' PRegisterPToken = 0 pcon' PMintPToken = 1 - -- redeemer data is untrusted and non-permanent so we can safely decide zero is + -- redeemer data is untrusted and non-permanent so we can safely decide zero is -- PRegisterPToken and anything else we consider PMintPToken. pmatch' x f = pif (x #== 0) (f PRegisterPToken) (f PMintPToken) @@ -41,7 +53,7 @@ instance PIsData PSmartTokenMintingAction where {-| Minting Policy for Programmable Logic Tokens -This minting policy enables the creation and management of programmable tokens with +This minting policy enables the creation and management of programmable tokens with configurable transfer and issuer logic. == Overview @@ -88,7 +100,7 @@ mkProgrammableLogicMinting :: ClosedTerm (PAsData PCredential :--> PAsData PCurr mkProgrammableLogicMinting = plam $ \programmableLogicBase nodeCS mintingLogicCred ctx -> P.do ctxF <- pletFields @'["txInfo", "redeemer", "scriptInfo"] ctx infoF <- pletFields @'["referenceInputs", "outputs", "mint", "wdrl"] ctxF.txInfo - let red = punsafeCoerce @_ @_ @PSmartTokenMintingAction (pto ctxF.redeemer) + let red = pfromData (punsafeCoerce @_ @_ @(PAsData PSmartTokenMintingAction) (pto ctxF.redeemer)) PMintingScript scriptInfo <- pmatch ctxF.scriptInfo ownCS <- plet $ pfield @"_0" # scriptInfo mintedValue <- plet $ pfromData infoF.mint @@ -100,7 +112,7 @@ mkProgrammableLogicMinting = plam $ \programmableLogicBase nodeCS mintingLogicCr ownTokenName <- plet (pfstBuiltin # ownTkPair) ownNumMinted <- plet (pfromData $ psndBuiltin # ownTkPair) txOutputs <- plet $ pfromData infoF.outputs - -- For ease of implementation of the POC we enforce that the first output must contain the minted tokens. + -- For ease of implementation of the POC we enforce that the first output must contain the minted tokens. -- This can be easily changed later. mintingToOutputF <- pletFields @'["value", "address"] (phead # txOutputs) @@ -114,7 +126,7 @@ mkProgrammableLogicMinting = plam $ \programmableLogicBase nodeCS mintingLogicCr -- It creates a permanent association between the currency symbol with a transferLogicScript and issuerLogicScript. -- All transfers of the token will be validated by either the transferLogicScript or the issuerLogicScript. -- This redeemer can only be invoked once per instance of this minting policy since the directory contracts do not permit duplicate - -- entries. + -- entries. PRegisterPToken -> P.do let nodeTkPairs = ptryLookupValue # nodeCS # mintedValue nodeTkPair <- plet (pheadSingleton # nodeTkPairs) diff --git a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs index 65d099b..e4d827c 100644 --- a/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs +++ b/src/lib/SmartTokens/Contracts/ProgrammableLogicBase.hs @@ -5,10 +5,15 @@ {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE UndecidableInstances #-} + module SmartTokens.Contracts.ProgrammableLogicBase ( + TokenProof (..), + ProgrammableLogicGlobalRedeemer (..), mkProgrammableLogicBase, - mkProgrammableLogicGlobal + mkProgrammableLogicGlobal, ) where import Plutarch.Builtin (pasByteStr, pasConstr, pforgetData) @@ -16,6 +21,7 @@ import Plutarch.Core.Utils (pand'List, pcanFind, pcountInputsFromCred, pelemAtFast, pfilterCSFromValue, phasDataCS, pisRewarding, pmustFind, ptxSignedByPkh, pvalidateConditions, pvalueContains) +import Plutarch.DataRepr (DerivePConstantViaData (..)) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.LedgerApi.V3 (AmountGuarantees (Positive), KeyGuarantees (Sorted), PCredential (..), @@ -25,6 +31,7 @@ import Plutarch.LedgerApi.V3 (AmountGuarantees (Positive), PScriptContext, PStakingCredential (PStakingHash), PTokenName, PTxInInfo, PTxOut (..), PValue (..), pdnothing) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData, PBool, PBuiltinList, PBuiltinPair, PByteString, @@ -35,9 +42,10 @@ import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData, S, Term, pcon, pconstant, pdata, pelem, perror, pfield, pfix, pfromData, pfstBuiltin, phoistAcyclic, pif, plam, plet, pletFields, pmap, pmatch, pnot, psndBuiltin, pto, - ptraceInfo, type (:-->), (#$), (#), (#||)) + ptraceInfo, type (:-->), (#$), (#), (#||), PShow) import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V1.Value (Value) +import PlutusTx qualified import SmartTokens.Types.ProtocolParams (PProgrammableLogicGlobalParams) import SmartTokens.Types.PTokenDirectory (PDirectorySetNode) @@ -56,6 +64,19 @@ pstripAda = phoistAcyclic $ -- The current implementation of the contracts in this module are not designed to be maximally efficient. -- In the future, this should be optimized to use the redeemer indexing design pattern to identify and validate -- the programmable inputs. +data TokenProof + = TokenExists Integer + | TokenDoesNotExist Integer + deriving stock (Show, Eq, Generic) + +PlutusTx.makeIsDataIndexed ''TokenProof + [('TokenExists, 0), ('TokenDoesNotExist, 1)] + +deriving via + (DerivePConstantViaData TokenProof PTokenProof) + instance + (PConstantDecl TokenProof) + data PTokenProof (s :: S) = PTokenExists @@ -69,11 +90,14 @@ data PTokenProof (s :: S) ) ) deriving stock (Generic) - deriving anyclass (PlutusType, PIsData, PEq) + deriving anyclass (PlutusType, PIsData, PEq, PShow) instance DerivePlutusType PTokenProof where type DPTStrat _ = PlutusTypeData +instance PUnsafeLiftDecl PTokenProof where + type PLifted PTokenProof = TokenProof + emptyValue :: Value emptyValue = mempty @@ -88,7 +112,7 @@ pvalueFromCred = phoistAcyclic $ plam $ \cred sigs scripts inputs -> self # pletFields @'["address", "value"] (pfield @"resolved" # txIn) (\txInF -> plet txInF.address $ \addr -> - pif (pfield @"credential" # addr #== cred) + pif ((pfield @"credential" # addr) #== cred) ( pmatch (pfield @"stakingCredential" # addr) $ \case PDJust ((pfield @"_0" #) -> stakingCred) -> @@ -280,7 +304,25 @@ pcheckTransferLogicAndGetProgrammableValue = plam $ \directoryNodeCS refInputs p in go # proofList # (ptail # mapInnerList) # pto (pto pemptyLedgerValue) -data ProgrammableLogicGlobalRedeemer (s :: S) +data ProgrammableLogicGlobalRedeemer + = TransferAct [TokenProof] + | SeizeAct { + plgrSeizeInputIdx :: Integer, + plgrSeizeOutputIdx :: Integer, + plgrDirectoryNodeIdx :: Integer + } + deriving (Show, Eq, Generic) + +PlutusTx.makeIsDataIndexed ''ProgrammableLogicGlobalRedeemer + [('TransferAct, 0), ('SeizeAct, 1)] + + +deriving via + (DerivePConstantViaData ProgrammableLogicGlobalRedeemer PProgrammableLogicGlobalRedeemer) + instance + (PConstantDecl ProgrammableLogicGlobalRedeemer) + +data PProgrammableLogicGlobalRedeemer (s :: S) = PTransferAct ( Term s ( PDataRecord '[ "proofs" ':= PBuiltinList (PAsData PTokenProof) ] ) ) | PSeizeAct @@ -296,17 +338,21 @@ data ProgrammableLogicGlobalRedeemer (s :: S) deriving stock (Generic) deriving anyclass (PlutusType, PIsData, PEq) -instance DerivePlutusType ProgrammableLogicGlobalRedeemer where +instance DerivePlutusType PProgrammableLogicGlobalRedeemer where type DPTStrat _ = PlutusTypeData +instance PUnsafeLiftDecl PProgrammableLogicGlobalRedeemer where + type PLifted PProgrammableLogicGlobalRedeemer = ProgrammableLogicGlobalRedeemer + mkProgrammableLogicGlobal :: ClosedTerm (PAsData PCurrencySymbol :--> PScriptContext :--> PUnit) mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do ctxF <- pletFields @'["txInfo", "redeemer", "scriptInfo"] ctx infoF <- pletFields @'["inputs", "referenceInputs", "outputs", "signatories", "wdrl"] ctxF.txInfo - let red = pfromData $ punsafeCoerce @_ @_ @(PAsData ProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer) + let red = pfromData $ punsafeCoerce @_ @_ @(PAsData PProgrammableLogicGlobalRedeemer) (pto ctxF.redeemer) referenceInputs <- plet $ pfromData infoF.referenceInputs -- Extract protocol parameter UTxO ptraceInfo "Extracting protocol parameter UTxO" + let paramUTxO = pfield @"resolved" #$ pmustFind @PBuiltinList @@ -321,7 +367,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do progLogicCred <- plet protocolParamsF.progLogicCred ptraceInfo "Extracting invoked scripts" - let invokedScripts = + invokedScripts <- plet $ pmap @PBuiltinList # plam (\wdrlPair -> let cred = pfstBuiltin # wdrlPair @@ -331,14 +377,12 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do pmatch red $ \case PTransferAct ((pfield @"proofs" #) -> proofs) -> P.do - ptraceInfo "PTransferAct valueFromCred" totalProgTokenValue <- plet $ pvalueFromCred # progLogicCred # infoF.signatories # invokedScripts # infoF.inputs - ptraceInfo "PTransferAct checkTransferLogicAndGetProgrammableValue" totalProgTokenValue_ <- plet $ pcheckTransferLogicAndGetProgrammableValue # protocolParamsF.directoryNodeCS @@ -346,7 +390,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do # pfromData proofs # invokedScripts # totalProgTokenValue - ptraceInfo "PTransferAct validateConditions" + pvalidateConditions [ pisRewarding ctxF.scriptInfo , pcheckTransferLogic @@ -369,13 +413,13 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do directoryNodeUTxO = pelemAtFast @PBuiltinList # referenceInputs # pfromData seizeActF.directoryNodeIdx seizeDirectoryNode <- pletFields @'["value", "datum"] (pfield @"resolved" # directoryNodeUTxO) POutputDatum ((pfield @"outputDatum" #) -> seizeDat') <- pmatch seizeDirectoryNode.datum - directoryNodeDatumF <- pletFields @'["key", "next", "transferLogicScript", "issuerLogicScript"] (punsafeCoerce @_ @_ @PDirectorySetNode (pto seizeDat')) + directoryNodeDatumF <- pletFields @'["key", "next", "transferLogicScript", "issuerLogicScript"] (punsafeCoerce @_ @_ @(PAsData PDirectorySetNode) (pto seizeDat')) seizeInputF <- pletFields @'["address", "value", "datum"] seizeInput seizeInputAddress <- plet seizeInputF.address seizeInputValue <- plet $ pfromData seizeInputF.value - seizeOutputValue <- plet $ pfilterCSFromValue # seizeInputValue # directoryNodeDatumF.key + expectedSeizeOutputValue <- plet $ pfilterCSFromValue # seizeInputValue # directoryNodeDatumF.key let expectedSeizeOutput = pdata $ @@ -384,7 +428,7 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do ( #address .= seizeInputF.address .& #value - .= pdata seizeOutputValue + .= pdata expectedSeizeOutputValue .& #datum .= seizeInputF.datum .& #referenceScript @@ -402,9 +446,9 @@ mkProgrammableLogicGlobal = plam $ \protocolParamsCS ctx -> P.do -- Prevent DDOS greifing attacks via the seize action -- i.e. the issuer logic script being used to spend a programmable token UTxO that does not have the given programmable token -- back to the mkProgrammableLogicBase script without modifying it (thus preventing any others from spending - -- that UTxO in that block). Or using it to repeatedly spend a programmable token UTxO that does have the programmable token back back to + -- that UTxO in that block). Or using it to repeatedly spend a programmable token UTxO that does have the programmable token back back to -- the mkProgrammableLogicBase script without removing the programmable token associated with the `issuerLogicCredential`. - , pnot # (pdata seizeInputValue #== pdata seizeOutputValue) + , pnot # (pdata seizeInputValue #== pdata expectedSeizeOutputValue) ] diff --git a/src/lib/SmartTokens/Core/Scripts.hs b/src/lib/SmartTokens/Core/Scripts.hs index efc2b02..6fcad66 100644 --- a/src/lib/SmartTokens/Core/Scripts.hs +++ b/src/lib/SmartTokens/Core/Scripts.hs @@ -5,25 +5,6 @@ module SmartTokens.Core.Scripts ( ) where import Plutarch -import Plutarch.ByteString (PByteString, plengthBS, psliceBS, pindexBS) -import Plutarch.Crypto (pkeccak_256, pblake2b_224) -import Plutarch.Integer (PInteger, pmod) -import Plutarch.Lift (pconstant) -import Plutarch.Bool (pif, (#==)) -import PlutusCore.Crypto.Hash qualified as Hash -import PlutusLedgerApi.Common (serialiseUPLC) -import Data.ByteString.Short (fromShort) -import Plutarch.Script (Script(unScript)) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.Word (Word8) -import PlutusLedgerApi.V2 ( - Data, - ExBudget, - ) -import Data.Text -import Plutarch.Evaluate -import Data.Bifunctor ( Bifunctor(first) ) tryCompile :: Config -> ClosedTerm a -> Script tryCompile cfg x = case compile cfg x of @@ -35,8 +16,3 @@ tryCompileTracingAndBinds = tryCompile (Tracing LogInfo DoTracingAndBinds) tryCompileNoTracing :: ClosedTerm a -> Script tryCompileNoTracing = tryCompile NoTracing - - - - - diff --git a/src/lib/SmartTokens/LinkedList/Common.hs b/src/lib/SmartTokens/LinkedList/Common.hs index b3c72ee..4223f71 100644 --- a/src/lib/SmartTokens/LinkedList/Common.hs +++ b/src/lib/SmartTokens/LinkedList/Common.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE QualifiedDo #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QualifiedDo #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} @@ -16,79 +16,32 @@ module SmartTokens.LinkedList.Common ( parseNodeOutputUtxoPair, ) where -import Plutarch.LedgerApi.Value (pnormalize) +import Plutarch.Bool (pand') +import Plutarch.Builtin (pasByteStr, pforgetData) +import Plutarch.Core.Utils (passert, pcountOfUniqueTokens, + pfindCurrencySymbolsByTokenPrefix, phasDataCS, + pheadSingleton, pmapFilter, psingletonOfCS, + ptryFromInlineDatum) import Plutarch.LedgerApi.AssocMap qualified as AssocMap +import Plutarch.LedgerApi.V3 (AmountGuarantees (NonZero, Positive), + KeyGuarantees (Sorted), PAddress, PCurrencySymbol, + POutputDatum (POutputDatum), PScriptContext, + PScriptInfo (PMintingScript), PTokenName, PTxOut, + PValue) +import Plutarch.LedgerApi.Value (pnormalize) import Plutarch.Monadic qualified as P -import Plutarch.Bool (pand') -import Plutarch.Prelude - ( Generic, - (#), - (#$), - phoistAcyclic, - plet, - pto, - pcon, - pmatch, - tcont, - type (:-->), - ClosedTerm, - PType, - S, - Term, - plam, - TermCont, - PByteString, - pconstant, - PEq((#==)), - PBool, - PPartialOrd((#<)), - PInteger, - (#&&), - pdata, - pfromData, - pfield, - pletFields, - pall, - plengthBS, - pany, - pfilter, - pmap, - pguardC, - PAsData, - PBuiltinList, - PListLike(pnull), - PMaybe(PJust), - PPair(..), - PUnit, pelimList ) +import Plutarch.Prelude (ClosedTerm, Generic, PAsData, PBool, PBuiltinList, + PByteString, PEq ((#==)), PInteger, PListLike (pnull), + PMaybe (PJust), PPair (..), PPartialOrd ((#<)), PType, + PUnit, S, Term, TermCont, pall, pany, pcon, pconstant, + pdata, pelimList, pfield, pfilter, pfromData, pguardC, + phoistAcyclic, plam, plength, plengthBS, plet, + pletFields, pmap, pmatch, pto, tcont, type (:-->), + (#$), (#&&), (#)) import Plutarch.Unsafe (punsafeCoerce) -import Plutarch.Core.Utils ( - passert, - pcountOfUniqueTokens, - pfindCurrencySymbolsByTokenPrefix, - pheadSingleton, - phasDataCS, - psingletonOfCS, - ptryFromInlineDatum, - pmapFilter, - ) +import SmartTokens.Types.PTokenDirectory (PDirectorySetNode, pisEmptyNode, + pisInsertedNode, pisInsertedOnNode) import Types.Constants (pnodeKeyTN, poriginNodeTN, ptryParseNodeKey) -import SmartTokens.Types.PTokenDirectory - ( PDirectorySetNode, - pisInsertedOnNode, - pisInsertedNode, - pisEmptyNode ) -import Plutarch.LedgerApi.V3 - ( KeyGuarantees(Sorted), - AmountGuarantees(NonZero, Positive), - PCurrencySymbol, - PTokenName, - PValue, - POutputDatum(POutputDatum), - PTxOut, - PScriptContext, - PScriptInfo(PMintingScript), - PAddress ) -import Plutarch.Builtin (pforgetData, pasByteStr) paysToAddress :: Term s (PAddress :--> (PAsData PTxOut) :--> PBool) paysToAddress = phoistAcyclic $ plam $ \adr txOut -> adr #== (pfield @"address" # txOut) @@ -111,7 +64,7 @@ correctNodeTokenMinted = phoistAcyclic $ tokenMap #== nodeMint -- Potentially use this in the future if we plan to manage additional --- value in the directory nodes. +-- value in the directory nodes. nodeInputUtxoDatumUnsafePair :: ClosedTerm ( PAsData PTxOut @@ -146,7 +99,7 @@ parseNodeOutputUtxo = phoistAcyclic $ let nodeKey = pasByteStr # nodeKeyData nodeNext = pasByteStr # pforgetData datumF.next - -- The following are checked by `pisInsertedNode` + -- The following are checked by `pisInsertedNode` -- passert "transferLogicScript deserialization" $ pdeserializesToCredential # datumF.transferLogicScript -- passert "issuerLogicScript deserialization" $ pdeserializesToCredential # datumF.issuerLogicScript @@ -158,7 +111,7 @@ parseNodeOutputUtxo = phoistAcyclic $ datum -- Potentially use this in the future if we plan to manage additional --- value in the directory nodes. +-- value in the directory nodes. parseNodeOutputUtxoPair :: ClosedTerm ( PAsData PCurrencySymbol @@ -217,7 +170,7 @@ makeCommon ctx' = do let atNodeValidator = pelimList - ( \firstNodeInput _ -> + ( \firstNodeInput _ -> let isSameAddress = (paysToAddress # (pfield @"address" # firstNodeInput)) in pall # isSameAddress # toNodeValidator ) @@ -244,9 +197,9 @@ makeCommon ctx' = do pure common --- | Initialize the linked list +-- | Initialize the linked list -- Validations: --- - No node inputs should be spent +-- - No node inputs should be spent -- - There should be only a single node token minted (the origin node token) -- - There should be exactly one node output, the key of which should be empty and the next key should be empty pInit :: forall (s :: S). PDirectoryCommon s -> Term s PUnit @@ -290,9 +243,9 @@ pInsert common = plam $ \pkToInsert -> P.do coveringDatumKey <- plet $ pasByteStr # pforgetData coveringDatumF.key coveringDatumNext <- plet $ pasByteStr # pforgetData coveringDatumF.next - -- The key of the spent node is lexographically less than pkToInsert and + -- The key of the spent node is lexographically less than pkToInsert and -- the next key of the spent node is lexographically greater than pkToInsert. - -- Thus the coveringNode is the node upon which we are inserting. + -- Thus the coveringNode is the node upon which we are inserting. passert "Spent node should cover inserting key" $ pand' # (coveringDatumKey #< keyToInsert) # (keyToInsert #< coveringDatumNext) @@ -318,8 +271,8 @@ data PDirectoryCommon (s :: S) = MkCommon , mint :: Term s (PValue 'Sorted 'NonZero) -- ^ value minted in current Tx , nodeInputs :: Term s (PBuiltinList (PAsData PDirectorySetNode)) - -- ^ node inputs in the tx + -- ^ node inputs in the tx , nodeOutputs :: Term s (PBuiltinList (PAsData PDirectorySetNode)) - -- ^ node outputs in the tx + -- ^ node outputs in the tx } deriving stock (Generic) diff --git a/src/lib/SmartTokens/LinkedList/MintDirectory.hs b/src/lib/SmartTokens/LinkedList/MintDirectory.hs index 7fae322..294033f 100644 --- a/src/lib/SmartTokens/LinkedList/MintDirectory.hs +++ b/src/lib/SmartTokens/LinkedList/MintDirectory.hs @@ -1,29 +1,76 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-unused-do-bind #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QualifiedDo #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} module SmartTokens.LinkedList.MintDirectory ( mkDirectoryNodeMP, + DirectoryNodeAction (..) ) where +import Data.Maybe (fromJust) +import Generics.SOP qualified as SOP +import Plutarch.Core.Utils (pand'List, passert, phasUTxO) +import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields) import Plutarch.LedgerApi.V3 (PScriptContext, PTxOutRef) +import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..)) import Plutarch.Monadic qualified as P -import Plutarch.Unsafe (punsafeCoerce) -import SmartTokens.LinkedList.Common (makeCommon, pInit, pInsert) - -import Plutarch.Core.Utils (pand'List, passert, phasUTxO) import Plutarch.Prelude (ClosedTerm, DerivePlutusType (..), Generic, PAsData, PByteString, PDataRecord, PEq, PIsData, PLabeledType ((:=)), PUnit, PlutusType, PlutusTypeData, S, Term, TermCont (runTermCont), pconstant, perror, pfield, pfromData, pif, plam, plet, pletFields, pmatch, pto, type (:-->), (#)) +import Plutarch.Unsafe (punsafeCoerce) +import PlutusCore.Data qualified as PLC +import PlutusLedgerApi.V3 (CurrencySymbol) +import PlutusTx qualified +import PlutusTx.Builtins.Internal qualified as BI +import SmartTokens.LinkedList.Common (makeCommon, pInit, pInsert) -------------------------------- -- FinSet Node Minting Policy: -------------------------------- +data DirectoryNodeAction + = InitDirectory + | InsertDirectoryNode CurrencySymbol + deriving stock (Show, Eq, Generic) + deriving anyclass (SOP.Generic) + +PlutusTx.makeIsDataIndexed ''DirectoryNodeAction + [('InitDirectory, 0), ('InsertDirectoryNode, 1)] + +-- instance PlutusTx.ToData DirectoryNodeAction where +-- toBuiltinData = \case +-- InitDirectory -> BI.dataToBuiltinData $ PLC.Constr 0 [] +-- InsertDirectoryNode sym -> BI.dataToBuiltinData $ PLC.Constr 1 [PlutusTx.toData sym] + +-- instance PlutusTx.FromData DirectoryNodeAction where +-- fromBuiltinData (BI.builtinDataToData -> d) = case d of +-- PLC.Constr 0 [] -> Just InitDirectory +-- PLC.Constr 1 [PlutusTx.fromData -> Just currencySymbol] -> Just (InsertDirectoryNode currencySymbol) +-- _ -> Nothing + +-- instance PlutusTx.UnsafeFromData DirectoryNodeAction where +-- unsafeFromBuiltinData = fromJust . PlutusTx.fromBuiltinData + +deriving via + (DerivePConstantViaData DirectoryNodeAction PDirectoryNodeAction) + instance + (PConstantDecl DirectoryNodeAction) data PDirectoryNodeAction (s :: S) = PInit (Term s (PDataRecord '[])) @@ -31,8 +78,12 @@ data PDirectoryNodeAction (s :: S) deriving stock (Generic) deriving anyclass (PlutusType, PIsData, PEq) +instance PUnsafeLiftDecl PDirectoryNodeAction where + type PLifted PDirectoryNodeAction = DirectoryNodeAction + instance DerivePlutusType PDirectoryNodeAction where type DPTStrat _ = PlutusTypeData + mkDirectoryNodeMP :: ClosedTerm ( PAsData PTxOutRef @@ -54,7 +105,7 @@ mkDirectoryNodeMP = plam $ \initUTxO ctx -> P.do PInsert action -> P.do act <- pletFields @'["keyToInsert"] action pkToInsert <- plet act.keyToInsert - let mintsProgrammableToken = pconstant False + let mintsProgrammableToken = pconstant True insertChecks = pand'List [ mintsProgrammableToken diff --git a/src/lib/SmartTokens/Types/Constants.hs b/src/lib/SmartTokens/Types/Constants.hs index a61e88f..a551404 100644 --- a/src/lib/SmartTokens/Types/Constants.hs +++ b/src/lib/SmartTokens/Types/Constants.hs @@ -2,21 +2,32 @@ module SmartTokens.Types.Constants( protocolParamsToken, pprotocolParamsToken, - pprotocolParamsTokenData + pprotocolParamsTokenData, + + -- * Directory node token name + directoryNodeToken, + pdirectoryNodeToken, + pdirectoryNodeTokenData ) where import Plutarch.LedgerApi.V1 (PTokenName (..)) -import Plutarch.Prelude - ( PAsData, pconstantData, ClosedTerm, pconstant ) -import PlutusLedgerApi.V1 (TokenName(..)) +import Plutarch.Prelude (ClosedTerm, PAsData, pconstant, pconstantData) +import PlutusLedgerApi.V1 (TokenName (..)) protocolParamsToken :: TokenName protocolParamsToken = "ProtocolParams" -pprotocolParamsToken :: ClosedTerm PTokenName +pprotocolParamsToken :: ClosedTerm PTokenName pprotocolParamsToken = pconstant protocolParamsToken pprotocolParamsTokenData :: ClosedTerm (PAsData PTokenName) pprotocolParamsTokenData = pconstantData protocolParamsToken +directoryNodeToken :: TokenName +directoryNodeToken = "" + +pdirectoryNodeToken :: ClosedTerm PTokenName +pdirectoryNodeToken = pconstant directoryNodeToken +pdirectoryNodeTokenData :: ClosedTerm (PAsData PTokenName) +pdirectoryNodeTokenData = pconstantData directoryNodeToken diff --git a/src/lib/SmartTokens/Types/PTokenDirectory.hs b/src/lib/SmartTokens/Types/PTokenDirectory.hs index 9123fd6..300ca92 100644 --- a/src/lib/SmartTokens/Types/PTokenDirectory.hs +++ b/src/lib/SmartTokens/Types/PTokenDirectory.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-unused-do-bind #-} {-# OPTIONS_GHC -Wno-partial-type-signatures #-} {-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} @@ -56,7 +57,6 @@ import PlutusTx (Data (B, Constr), FromData, ToData, UnsafeFromData) -- Note: Dont put comments over the setup line! -- - data BlacklistNode = BlacklistNode { blnKey :: BuiltinByteString, @@ -67,9 +67,39 @@ data BlacklistNode = deriving (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) via (ProductIsData BlacklistNode) +-- instance PlutusTx.ToData BlacklistNode where +-- toBuiltinData BlacklistNode{blnKey, blnNext} = +-- let blnKeyBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnKey) +-- blnNextBstr = head $ snd $ BI.unsafeDataAsConstr (toBuiltinData blnNext) +-- in BI.mkList [blnKeyBstr, blnNextBstr] +-- +-- instance PlutusTx.FromData BlacklistNode where +-- fromBuiltinData builtinData = +-- let fields = BI.unsafeDataAsList builtinData +-- key = head fields +-- fields1 = tail fields +-- next = head fields1 +-- in Just $ undefined -- Don't know how to determine whether credential is pub key or script + + deriving via (DerivePConstantViaData BlacklistNode PBlacklistNode) instance (PConstantDecl BlacklistNode) +{- +>>> _printTerm $ unsafeEvalTerm NoTracing (mkRecordConstr PBlacklistNode (#blnKey .= pconstant "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff" .& #blnNext .= pconstant "")) +No instance for `IsString (PAsDataLifted PByteString)' + arising from the literal `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the first argument of `pconstant', namely + `"ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the second argument of `(.=)', namely + `pconstant + "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +In the first argument of `(.&)', namely + `#blnKey + .= + pconstant + "ffffffffffffffffffffffffffffffffffffffffffffffffffffffff"' +-} newtype PBlacklistNode (s :: S) = PBlacklistNode ( Term @@ -101,7 +131,6 @@ instance PUnsafeLiftDecl PBlacklistNode where -- >>> printTerm NoTracing (pconstantData $ BlacklistNode { blnKey = "a hi", blnNext = "a" }) -- "program 1.0.0 (List [B #61206869, B #61])" - type PBlacklistNodeHRec (s :: S) = HRec '[ '("key", Term s (PAsData PByteString)) @@ -190,12 +219,20 @@ isTailNode :: ClosedTerm (PAsData PDirectorySetNode :--> PBool) isTailNode = plam $ \node -> pfield @"next" # node #== pemptyCSData -pisEmptyNode :: ClosedTerm (PAsData PDirectorySetNode :--> PBool) -pisEmptyNode = plam $ \node -> +{-| + +>>> _printTerm $ unsafeEvalTerm NoTracing emptyNode +"program\n 1.0.0\n (List\n [ B #\n , B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff\n , Constr 0 [B #]\n , Constr 0 [B #] ])" +-} +emptyNode :: ClosedTerm (PAsData PDirectorySetNode) +emptyNode = let nullTransferLogicCred = pconstant (Constr 0 [PlutusTx.B ""]) nullIssuerLogicCred = pconstant (Constr 0 [PlutusTx.B ""]) - expectedEmptyNode = punsafeCoerce $ plistData # pmkBuiltinList [pforgetData pemptyBSData, pforgetData ptailNextData, nullTransferLogicCred, nullIssuerLogicCred] - in node #== expectedEmptyNode + in punsafeCoerce $ plistData # pmkBuiltinList [pforgetData pemptyBSData, pforgetData ptailNextData, nullTransferLogicCred, nullIssuerLogicCred] + +pisEmptyNode :: ClosedTerm (PAsData PDirectorySetNode :--> PBool) +pisEmptyNode = plam $ \node -> + node #== emptyNode pemptyBSData :: ClosedTerm (PAsData PByteString) pemptyBSData = unsafeEvalTerm NoTracing (punsafeCoerce (pconstant $ PlutusTx.B "")) @@ -226,12 +263,20 @@ pisInsertedOnNode = phoistAcyclic $ pisInsertedNode :: ClosedTerm (PAsData PByteString :--> PAsData PByteString :--> PAsData PDirectorySetNode :--> PBool) pisInsertedNode = phoistAcyclic $ plam $ \insertedKey coveringNext outputNode -> - pletFields @'["transferLogicScript", "issuerLogicScript"] outputNode $ \outputNodeDatumF -> + pletFields @'["transferLogicScript", "issuerLogicScript", "key", "next"] outputNode $ \outputNodeDatumF -> let transferLogicCred_ = outputNodeDatumF.transferLogicScript issuerLogicCred_ = outputNodeDatumF.issuerLogicScript expectedDirectoryNode = - pmkDirectorySetNode # insertedKey # coveringNext # pdeserializeCredential transferLogicCred_ # pdeserializeCredential issuerLogicCred_ - in outputNode #== expectedDirectoryNode + pmkDirectorySetNode # insertedKey # coveringNext # transferLogicCred_ # issuerLogicCred_ + + -- TODO (jm): Uncommenting the following line results in an error. This is spdeserializeCredential trange because the check below + -- asserts that the 'key' and 'next' fields of 'outputnode' are equal to what we expect, and the other two + -- fields (transferLogicScript, issuerLogicScript) should also be equal when we construct the 'expectedDirectoryNode' + + in ptraceInfo (pshow $ pmkBuiltinList [pforgetData expectedDirectoryNode]) $ outputNode #== expectedDirectoryNode + + -- in pforgetData insertedKey #== pforgetData outputNodeDatumF.key + -- #&& pforgetData coveringNext #== pforgetData ptailNextData pdeserializeCredential :: Term s (PAsData PCredential) -> Term s (PAsData PCredential) pdeserializeCredential term = diff --git a/src/lib/SmartTokens/Types/ProtocolParams.hs b/src/lib/SmartTokens/Types/ProtocolParams.hs index cddae7f..bdc8dbb 100644 --- a/src/lib/SmartTokens/Types/ProtocolParams.hs +++ b/src/lib/SmartTokens/Types/ProtocolParams.hs @@ -1,22 +1,29 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-deferred-type-errors #-} +{-# LANGUAGE InstanceSigs #-} module SmartTokens.Types.ProtocolParams ( ProgrammableLogicGlobalParams (..), PProgrammableLogicGlobalParams (..), ) where -import Plutarch.Core.PlutusDataList - ( DerivePConstantViaDataList(..), - PlutusTypeDataList, - ProductIsData(..) ) +import Cardano.Api.Shelley qualified as C +import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=)) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (Bifunctor (..)) import Generics.SOP qualified as SOP -import Plutarch.LedgerApi.V3 (PCurrencySymbol, PCredential) -import Plutarch.Prelude +import Plutarch.Core.PlutusDataList (DerivePConstantViaDataList (..), + PlutusTypeDataList, ProductIsData (..)) import Plutarch.DataRepr (PDataFields) -import PlutusTx qualified -import PlutusLedgerApi.V3 (Credential, CurrencySymbol) +import Plutarch.LedgerApi.V3 (PCredential, PCurrencySymbol) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) +import Plutarch.Prelude (DerivePlutusType (..), Generic, PDataRecord, PEq, + PIsData, PLabeledType ((:=)), PShow, PlutusType, S, + Term) +import PlutusLedgerApi.V3 (Credential, CurrencySymbol) +import PlutusTx qualified -- TODO: -- Figure out why deriving PlutusType breaks when I uncomment this @@ -48,4 +55,28 @@ instance DerivePlutusType PProgrammableLogicGlobalParams where type DPTStrat _ = PlutusTypeDataList instance PUnsafeLiftDecl PProgrammableLogicGlobalParams where - type PLifted PProgrammableLogicGlobalParams = ProgrammableLogicGlobalParams \ No newline at end of file + type PLifted PProgrammableLogicGlobalParams = ProgrammableLogicGlobalParams + +-- We're using the Data representation of the PlutusLedgerApi types here +-- Because it is somewhat human-readable (more so than the hex representation) + +plutusDataToJSON :: forall a. (PlutusTx.ToData a) => a -> Aeson.Value +plutusDataToJSON = C.scriptDataToJson C.ScriptDataJsonNoSchema . C.unsafeHashableScriptData . C.fromPlutusData . PlutusTx.toData + +plutusDataFromJSON :: forall a. (PlutusTx.FromData a) => Aeson.Value -> Either String a +plutusDataFromJSON val = do + k <- bimap show C.getScriptData $ C.scriptDataFromJson C.ScriptDataJsonNoSchema val + maybe (Left "fromData failed") Right (PlutusTx.fromData $ C.toPlutusData k) + +instance ToJSON ProgrammableLogicGlobalParams where + toJSON ProgrammableLogicGlobalParams{directoryNodeCS, progLogicCred} = + object + [ "directory_node_currency_symbol" .= plutusDataToJSON directoryNodeCS + , "programmable_logic_credential" .= plutusDataToJSON progLogicCred + ] + +instance FromJSON ProgrammableLogicGlobalParams where + parseJSON = withObject "ProgrammableLogicGlobalParams" $ \obj -> + ProgrammableLogicGlobalParams + <$> (obj .: "directory_node_currency_symbol" >>= either fail pure . plutusDataFromJSON) + <*> (obj .: "programmable_logic_credential" >>= either fail pure . plutusDataFromJSON) diff --git a/src/lib/Wst/App.hs b/src/lib/Wst/App.hs new file mode 100644 index 0000000..256581e --- /dev/null +++ b/src/lib/Wst/App.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-| Application monad used by CLI and server +-} +module Wst.App ( + WstApp(..), + runWstApp, + runWstAppServant +) where + +import Blammo.Logging.Simple (MonadLogger, MonadLoggerIO, WithLogger (..)) +import Cardano.Api qualified as C +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) +import Convex.Blockfrost (BlockfrostT (..), evalBlockfrostT) +import Convex.Class (MonadBlockchain, MonadUtxoQuery) +import Data.String (IsString (..)) +import Servant.Server (Handler (..)) +import Servant.Server qualified as S +import Wst.AppError (AppError (BlockfrostErr)) +import Wst.Offchain.Env (RuntimeEnv (..)) +import Wst.Offchain.Env qualified as Env + +newtype WstApp env era a = WstApp { unWstApp :: ReaderT env (ExceptT (AppError era) (BlockfrostT IO)) a } + deriving newtype (Monad, Applicative, Functor, MonadIO, MonadReader env, MonadError (AppError era), MonadUtxoQuery, MonadBlockchain C.ConwayEra) + deriving + (MonadLogger, MonadLoggerIO) + via (WithLogger env (ExceptT (AppError era) (BlockfrostT IO))) + +runWstApp :: forall env era a. (Env.HasRuntimeEnv env) => env -> WstApp env era a -> IO (Either (AppError era) a) +runWstApp env WstApp{unWstApp} = do + let RuntimeEnv{envBlockfrost} = Env.runtimeEnv env + evalBlockfrostT envBlockfrost (runExceptT (runReaderT unWstApp env)) >>= \case + Left e -> pure (Left $ BlockfrostErr e) + Right a -> pure a + +{-| Interpret the 'WstApp' in a servant handler +-} +runWstAppServant :: forall env era a. (Env.HasRuntimeEnv env) => env -> WstApp env era a -> Handler a +runWstAppServant env action = liftIO (runWstApp env action) >>= \case + Left err -> do + let err_ = S.err500 { S.errBody = fromString (show err) } + throwError err_ + Right a -> pure a diff --git a/src/lib/Wst/AppError.hs b/src/lib/Wst/AppError.hs new file mode 100644 index 0000000..1779451 --- /dev/null +++ b/src/lib/Wst/AppError.hs @@ -0,0 +1,17 @@ +{-| Error type for endpoints and queries +-} +module Wst.AppError( + AppError(..) +) where + +import Blockfrost.Client.Core (BlockfrostError) +import Convex.CoinSelection qualified as CoinSelection +import PlutusLedgerApi.Data.V3 (Credential) + +data AppError era = + OperatorNoUTxOs -- ^ The operator does not have any UTxOs + | GlobalParamsNodeNotFound -- ^ The node with the global parameters was not found + | BalancingError (CoinSelection.BalanceTxError era) + | BlockfrostErr BlockfrostError + | TransferBlacklistedCredential Credential -- ^ Attempting to transfer funds from a blacklisted address + deriving stock (Show) diff --git a/src/lib/Wst/Cli.hs b/src/lib/Wst/Cli.hs index 02e89ff..5535ac3 100644 --- a/src/lib/Wst/Cli.hs +++ b/src/lib/Wst/Cli.hs @@ -1,4 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} module Wst.Cli(runMain) where +import Blammo.Logging.Simple (MonadLogger, logError, logInfo, runLoggerLoggingT) +import Control.Monad.IO.Class (MonadIO (..)) +import Convex.Wallet.Operator (OperatorConfigSigning) +import Convex.Wallet.Operator qualified as Operator +import Data.String (IsString (..)) +import Options.Applicative (customExecParser, disambiguate, helper, idm, info, + prefs, showHelpOnEmpty, showHelpOnError) +import Wst.App (runWstApp) +import Wst.Cli.Command (Command (..), ManageCommand (StartServer, Status), + parseCommand) +import Wst.Offchain.Env qualified as Env +import Wst.Server qualified as Server + runMain :: IO () -runMain = putStrLn "Starting stablecoin POC server" \ No newline at end of file +runMain = do + customExecParser + (prefs $ disambiguate <> showHelpOnEmpty <> showHelpOnError) + (info (helper <*> parseCommand) idm) + >>= runCommand + +runCommand :: Command -> IO () +runCommand com = do + env <- Env.addRuntimeEnv <$> Env.loadRuntimeEnv <*> pure Env.empty + result <- case com of + Deploy config -> runWstApp env (deploy config) + Manage txIn com -> do + let env' = Env.addDirectoryEnvFor txIn env + runWstApp env' $ case com of + Status -> do + -- TODO: status check (call the query endpoints and print out a summary of the results) + logInfo "Manage" + StartServer -> do + logInfo "starting server" + liftIO (Server.runServer env') + + case result of + Left err -> runLoggerLoggingT env $ logError (fromString $ show err) + Right a -> pure a + +deploy :: (MonadLogger m, MonadIO m) => OperatorConfigSigning -> m () +deploy config = do + logInfo "Loading operator files" + _operator <- liftIO (Operator.loadOperatorFiles config) + -- TODO: + -- Use blockfrost backend to run Wst.Offchain.Endpoints.Deployment with the operator's funds + -- Then use operator key to sign + -- Then submit transaction to blockfrost + -- Convex.Blockfrost.runBLockfrostT for the monadblockchain / monadutxoquery effects + pure () diff --git a/src/lib/Wst/Cli/Command.hs b/src/lib/Wst/Cli/Command.hs new file mode 100644 index 0000000..e1a0ed7 --- /dev/null +++ b/src/lib/Wst/Cli/Command.hs @@ -0,0 +1,72 @@ +{-| The CLI commands and parsers +-} +module Wst.Cli.Command( + parseCommand, + Command(..), + ManageCommand(..) +) where + +import Cardano.Api (TxIn (..), TxIx (..)) +import Control.Monad (when) +import Convex.Wallet.Operator (OperatorConfigSigning, + parseOperatorConfigSigning) +import Data.String (IsString (..)) +import Options.Applicative (CommandFields, Mod, Parser, ReadM, argument, + command, eitherReader, fullDesc, help, info, long, + many, metavar, optional, progDesc, short, str, + strOption, subparser, (<|>)) +import Text.Read (readMaybe) + +parseCommand :: Parser Command +parseCommand = + subparser $ + mconcat + [ parseDeploy + , parseManage + ] + +data Command = + Deploy OperatorConfigSigning + | Manage TxIn ManageCommand + deriving Show + +-- | Commands that require a deployed system +data ManageCommand = + Status + | StartServer + deriving stock Show + +parseDeploy :: Mod CommandFields Command +parseDeploy = + command "deploy" $ + info (Deploy <$> parseOperatorConfigSigning) (fullDesc <> progDesc "Deploy the directory and global params") + +parseManage :: Mod CommandFields Command +parseManage = + command "manage" $ + info (Manage <$> parseTxIn <*> parseManageCommand) (fullDesc <> progDesc "Manage a deployed system") + +parseManageCommand :: Parser ManageCommand +parseManageCommand = subparser $ mconcat [parseStatus] + +parseStatus :: Mod CommandFields ManageCommand +parseStatus = + command "status" $ + info (pure Status) (fullDesc <> progDesc "Show the status of the programmable tokens") + +parseTxIn :: Parser TxIn +parseTxIn = + argument + txInReader + (help "The TxIn that was selected when deploying the system. Format: ." <> metavar "TX_IN") + +txInReader :: ReadM TxIn +txInReader = eitherReader $ \str -> do + (txId, txIx) <- case break ((==) '.') str of + (txId, _:txIx) -> Right (txId, txIx) + _ -> Left "Expected ." + when (length txId /= 64) $ Left "Expected tx ID with 64 characters" + ix <- case readMaybe @Word txIx of + Nothing -> Left "Expected tx index" + Just n -> Right (TxIx n) + return $ TxIn (fromString txId) ix diff --git a/src/lib/Wst/Client.hs b/src/lib/Wst/Client.hs new file mode 100644 index 0000000..6ff262c --- /dev/null +++ b/src/lib/Wst/Client.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TypeApplications #-} + +{- | This module contains the client endpoints of the server. +-} +module Wst.Client ( + getHealthcheck, + + -- * Query routes + getGlobalParams, + + -- * Build tx + postIssueProgrammableTokenTx, +) where + +import Cardano.Api qualified as C +import Data.Data (Proxy (..)) +import Servant.API (NoContent, (:<|>) ((:<|>))) +import Servant.Client (ClientEnv, client, runClientM) +import Servant.Client.Core (ClientError) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.Offchain.Query (UTxODat) +import Wst.Server.Types (API, APIInEra, IssueProgrammableTokenArgs (..), + TextEnvelopeJSON) + +getHealthcheck :: ClientEnv -> IO (Either ClientError NoContent) +getHealthcheck env = do + let healthcheck :<|> _ = client (Proxy @APIInEra) + runClientM healthcheck env + +getGlobalParams :: forall era. C.IsShelleyBasedEra era => ClientEnv -> IO (Either ClientError (UTxODat era ProgrammableLogicGlobalParams)) +getGlobalParams env = do + let _ :<|> globalParams :<|> _ = client (Proxy @(API era)) + runClientM globalParams env + +postIssueProgrammableTokenTx :: forall era. C.IsShelleyBasedEra era => ClientEnv -> IssueProgrammableTokenArgs -> IO (Either ClientError (TextEnvelopeJSON (C.Tx era))) +postIssueProgrammableTokenTx env args = do + let _ :<|> _ :<|> issueProgrammableTokenTx = client (Proxy @(API era)) + runClientM (issueProgrammableTokenTx args) env diff --git a/src/lib/Wst/Offchain.hs b/src/lib/Wst/Offchain.hs index 83c36c4..d58cf2f 100644 --- a/src/lib/Wst/Offchain.hs +++ b/src/lib/Wst/Offchain.hs @@ -1,3 +1,3 @@ module Wst.Offchain() where --- Add tx building, tx submission, querying functions \ No newline at end of file +-- Add tx building, tx submission, querying functions diff --git a/src/lib/Wst/Offchain/BuildTx/Blacklist.hs b/src/lib/Wst/Offchain/BuildTx/Blacklist.hs new file mode 100644 index 0000000..6524701 --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/Blacklist.hs @@ -0,0 +1,2 @@ + +module Wst.Offchain.BuildTx.Blacklist () where diff --git a/src/lib/Wst/Offchain/BuildTx/Common.hs b/src/lib/Wst/Offchain/BuildTx/Common.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs new file mode 100644 index 0000000..9911865 --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/DirectorySet.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Wst.Offchain.BuildTx.DirectorySet ( + initDirectorySet, + InsertNodeArgs(..), + insertDirectoryNode, + -- * Values + initialNode +) where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens (over) +import Control.Monad.Reader (MonadReader, asks) +import Convex.BuildTx (MonadBuildTx, addBtx, addReference, mintPlutus, + prependTxOut, spendPlutusInlineDatum) +import Convex.CardanoApi.Lenses qualified as L +import Convex.Class (MonadBlockchain, queryNetworkId) +import Convex.PlutusLedger.V1 (transStakeCredential, unTransAssetName) +import Convex.Scripts (toHashableScriptData) +import Convex.Utils qualified as Utils +import Data.ByteString.Base16 (decode) +import GHC.Exts (IsList (..)) +import Plutarch (Config (NoTracing)) +import Plutarch.Evaluate (unsafeEvalTerm) +import Plutarch.Prelude (pconstantData) +import PlutusLedgerApi.V1 qualified as PlutusTx +import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..)) +import PlutusTx.Prelude (toBuiltin) +import SmartTokens.CodeLens (_printTerm) +import SmartTokens.LinkedList.MintDirectory (DirectoryNodeAction (..)) +import SmartTokens.Types.Constants (directoryNodeToken) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query (UTxODat (..)) +import Wst.Offchain.Scripts (directoryNodeMintingScript, + directoryNodeSpendingScript, scriptPolicyIdV3) + +_unused :: String +_unused = _printTerm $ unsafeEvalTerm NoTracing (pconstantData initialNode) + +{-| + +>>> _printTerm $ unsafeEvalTerm NoTracing (pconstantData initialNode) +"program\n 1.0.0\n (List\n [ B #\n , B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff\n , Constr 0 [B #]\n , Constr 0 [B #] ])" +-} +initialNode :: DirectorySetNode +initialNode = DirectorySetNode + { key = CurrencySymbol "" + , next = CurrencySymbol $ toBuiltin $ either (error "bytestring") id $ decode "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + , transferLogicScript = PubKeyCredential "" + , issuerLogicScript = PubKeyCredential "" + } + +initDirectorySet :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +initDirectorySet = Utils.inBabbage @era $ do + txIn <- asks (Env.dsTxIn . Env.directoryEnv) + paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) + netId <- queryNetworkId + let mintingScript = directoryNodeMintingScript txIn + + mintPlutus mintingScript InitDirectory (unTransAssetName directoryNodeToken) 1 + + let + val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra + $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) (unTransAssetName directoryNodeToken), 1)] + + addr = + C.makeShelleyAddressInEra + C.shelleyBasedEra + netId + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId) + C.NoStakeAddress + + dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData initialNode + + output :: C.TxOut C.CtxTx era + output = C.TxOut addr val dat C.ReferenceScriptNone + + prependTxOut output + + +{-| Data for a new node to be inserted into the directory +-} +data InsertNodeArgs = + InsertNodeArgs + { inaNewKey :: CurrencySymbol + , inaTransferLogic :: C.StakeCredential + , inaIssuerLogic :: C.StakeCredential + } + +insertDirectoryNode :: forall era env m ctx. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => UTxODat era ProgrammableLogicGlobalParams -> UTxODat era DirectorySetNode -> InsertNodeArgs -> m () +insertDirectoryNode UTxODat{uIn=paramsRef} UTxODat{uIn, uOut=firstTxOut, uDatum=firstTxData} InsertNodeArgs{inaNewKey, inaTransferLogic, inaIssuerLogic} = Utils.inBabbage @era $ do + netId <- queryNetworkId + initialTxIn <- asks (Env.dsTxIn . Env.directoryEnv) + paramsPolicyId <- asks (Env.protocolParamsPolicyId . Env.directoryEnv) + directorySpendingScript <- asks (Env.dsDirectorySpendingScript . Env.directoryEnv) + directoryMintingScript <- asks (Env.dsDirectoryMintingScript . Env.directoryEnv) + let + + firstTxVal :: C.TxOutValue era + firstTxVal = case firstTxOut of + (C.TxOut _ v _ _) -> v + + newTokenName = + let CurrencySymbol s = inaNewKey + in C.AssetName $ PlutusTx.fromBuiltin s + + newVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra + $ fromList [(C.AssetId (scriptPolicyIdV3 directoryMintingScript) newTokenName, 1)] + + addr = + C.makeShelleyAddressInEra + C.shelleyBasedEra + netId + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 $ directoryNodeSpendingScript paramsPolicyId ) + C.NoStakeAddress + + dsn = DirectorySetNode + { key = inaNewKey + , next = next firstTxData + , transferLogicScript = transStakeCredential inaTransferLogic + , issuerLogicScript = transStakeCredential inaIssuerLogic + } + newDat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData dsn + + insertedNode = C.TxOut addr newVal newDat C.ReferenceScriptNone + + firstDat = firstTxData { next = inaNewKey } + firstOutput = C.TxOut addr firstTxVal (C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData firstDat) C.ReferenceScriptNone + + addReference paramsRef + spendPlutusInlineDatum uIn directorySpendingScript () + mintPlutus directoryMintingScript (InsertDirectoryNode inaNewKey) newTokenName 1 + prependTxOut insertedNode + prependTxOut firstOutput diff --git a/src/lib/Wst/Offchain/BuildTx/ExampleTransfer.hs b/src/lib/Wst/Offchain/BuildTx/ExampleTransfer.hs new file mode 100644 index 0000000..b1180fc --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/ExampleTransfer.hs @@ -0,0 +1,39 @@ + +module Wst.Offchain.ExampleTransfer ( + issueStablecoin, + transferStablecoin, + seizeStablecoin + ) + where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens (over) +import Convex.BuildTx (MonadBuildTx, addBtx, addReference, + addStakeScriptWitness, addWithdrawalWithTxBody, + buildScriptWitness, findIndexReference, mintPlutus, + spendPlutusInlineDatum, + spendPlutusRefWithoutInRefInlineDatum, + spendPublicKeyOutput) +import Convex.CardanoApi.Lenses qualified as L +import Convex.PlutusLedger (transPolicyId, unTransAssetName) +import Convex.Scripts (fromHashableScriptData, toHashableScriptData) +import Data.Foldable (maximumBy) +import Data.Function (on) +import Data.List (find) +import GHC.Exts (IsList (..)) +import GHC.Generics (Generic) +import PlutusLedgerApi.V3 (Credential (..), CurrencySymbol (..)) +import PlutusLedgerApi.V3 qualified as P +import PlutusTx qualified +import Wst.Offchain.DirectorySet (DirectorySetNode (..)) + + +issueStablecoin :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.Hash C.PaymentKey -> m () +issueStablecoin = undefined + +transferStablecoin :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.Hash C.PaymentKey -> m () +transferStablecoin = undefined + +seizeStablecoin :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> C.Hash C.PaymentKey -> m () +seizeStablecoin = undefined diff --git a/src/lib/Wst/Offchain/BuildTx/LinkedList.hs b/src/lib/Wst/Offchain/BuildTx/LinkedList.hs new file mode 100644 index 0000000..5c9f3cb --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/LinkedList.hs @@ -0,0 +1,18 @@ + + +module Wst.Offchain.BuildTx.LinkedList ( + initLinkedList, + insertLinkedList +) where + +import Cardano.Api qualified as C +import Convex.BuildTx (MonadBuildTx) + + +initLinkedList :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> k -> m () +initLinkedList _netId _key = do + pure () + +insertLinkedList :: (MonadBuildTx C.ConwayEra m) => C.NetworkId -> k -> m () +insertLinkedList _netId _k = do + pure () diff --git a/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs new file mode 100644 index 0000000..fc32068 --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/ProgrammableLogic.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use second" #-} +module Wst.Offchain.BuildTx.ProgrammableLogic + ( + IssueNewTokenArgs (..), + alwaysSucceedsArgs, + fromTransferEnv, + issueProgrammableToken, + transferProgrammableToken, + seizeProgrammableToken, + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens ((^.)) +import Control.Monad.Reader (MonadReader, asks) +import Convex.BuildTx (MonadBuildTx, addReference, addWithdrawalWithTxBody, + buildScriptWitness, findIndexReference, + findIndexSpending, mintPlutus, prependTxOut, + spendPlutusInlineDatum) +import Convex.CardanoApi.Lenses as L +import Convex.Class (MonadBlockchain (queryNetworkId)) +import Convex.PlutusLedger.V1 (transPolicyId, unTransCredential, + unTransPolicyId) +import Convex.Utils qualified as Utils +import Data.Foldable (find, maximumBy, traverse_) +import Data.Function (on) +import Data.List (partition) +import Data.Maybe (fromJust) +import GHC.Exts (IsList (..)) +import PlutusLedgerApi.V3 (CurrencySymbol (..)) +import SmartTokens.Contracts.Issuance (SmartTokenMintingAction (MintPToken, RegisterPToken)) +import SmartTokens.Contracts.ProgrammableLogicBase (ProgrammableLogicGlobalRedeemer (..), + TokenProof (..)) +import SmartTokens.Types.ProtocolParams +import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) +import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..), + insertDirectoryNode) +import Wst.Offchain.Env (TransferLogicEnv (..)) +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query (UTxODat (..)) +import Wst.Offchain.Scripts (alwaysSucceedsScript, + programmableLogicMintingScript) + +data IssueNewTokenArgs = IssueNewTokenArgs + { intaMintingLogic :: C.PlutusScript C.PlutusScriptV3, -- TODO: We could add a parameter for the script 'lang' instead of fixing it to PlutusV3 + intaTransferLogic :: C.PlutusScript C.PlutusScriptV3, + intaIssuerLogic :: C.PlutusScript C.PlutusScriptV3 + } + +{-| 'IssueNewTokenArgs' for the policy that always succeeds (no checks) +-} +alwaysSucceedsArgs :: IssueNewTokenArgs +alwaysSucceedsArgs = + IssueNewTokenArgs + { intaMintingLogic = alwaysSucceedsScript + , intaTransferLogic = alwaysSucceedsScript + , intaIssuerLogic = alwaysSucceedsScript + } + +{-| 'IssueNewTokenArgs' for the transfer logic +-} +fromTransferEnv :: TransferLogicEnv -> IssueNewTokenArgs +fromTransferEnv TransferLogicEnv{tleMintingScript, tleTransferScript, tleIssuerScript} = + IssueNewTokenArgs + { intaMintingLogic = tleMintingScript + , intaTransferLogic = tleTransferScript + , intaIssuerLogic = tleIssuerScript + } + +{- Issue a programmable token and register it in the directory set if necessary. The caller should ensure that the specific + minting logic stake script witness is included in the final transaction. + - If the programmable token is not in the directory, then it is registered + - If the programmable token is in the directory, then it is minted +-} +issueProgrammableToken :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> IssueNewTokenArgs -> [UTxODat era DirectorySetNode] -> m C.PolicyId +issueProgrammableToken paramsTxOut (an, q) IssueNewTokenArgs{intaMintingLogic, intaTransferLogic, intaIssuerLogic} directoryList = Utils.inBabbage @era $ do + let ProgrammableLogicGlobalParams {directoryNodeCS, progLogicCred} = uDatum paramsTxOut + + progLogicScriptCredential <- either (const $ error "could not parse protocol params") pure $ unTransCredential progLogicCred + directoryNodeSymbol <- either (const $ error "could not parse protocol params") pure $ unTransPolicyId directoryNodeCS + + let mintingScript = programmableLogicMintingScript progLogicScriptCredential (C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaMintingLogic) directoryNodeSymbol + issuedPolicyId = C.scriptPolicyId $ C.PlutusScript C.PlutusScriptV3 mintingScript + issuedSymbol = transPolicyId issuedPolicyId + + udat@UTxODat{uDatum = dirNodeData} = + maximumBy (compare `on` (key . uDatum)) $ + filter ((<= issuedSymbol) . key . uDatum) directoryList + + if key dirNodeData == issuedSymbol + then + mintPlutus mintingScript MintPToken an q + else do + let nodeArgs = + InsertNodeArgs + { inaNewKey = issuedSymbol + , inaTransferLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaTransferLogic + , inaIssuerLogic = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.plutusScriptVersion intaIssuerLogic + } + + mintPlutus mintingScript RegisterPToken an q + insertDirectoryNode paramsTxOut udat nodeArgs + + pure issuedPolicyId + +{- User facing transfer of programmable tokens from one address to another. + The caller should ensure that the specific transfer logic stake script + witness is included in the final transaction. + + NOTE: If the token is not in the directory, then the function will + use a PDoesNotExist redeemer to prove that the token is not programmable + + IMPORTANT: The caller should ensure that the destination address of the + programmable token(s) in this transaction all correspond to the same + programmable logic payment credential (even in the case of non-programmable + tokens) otherwise the transaction will fail onchain validation. +-} +transferProgrammableToken :: forall env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> [C.TxIn] -> CurrencySymbol -> [UTxODat era DirectorySetNode] -> m () +transferProgrammableToken _ _ _ [] = error "directory list not initialised" +transferProgrammableToken paramsTxIn tokenTxIns programmableTokenSymbol directoryList = Utils.inBabbage @era $ do + nid <- queryNetworkId + + baseSpendingScript <- asks (Env.dsProgrammableLogicBaseScript . Env.directoryEnv) + globalStakeScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv) + + + let globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript + + -- Finds the directory node with the highest key that is less than or equal + -- to the programmable token symbol + UTxODat{uIn = dirNodeRef, uDatum = dirNodeDat} = + maximumBy (compare `on` (key . uDatum)) $ + filter ((<= programmableTokenSymbol) . key . uDatum) directoryList + + -- Finds the index of the directory node reference in the transaction ref + -- inputs + directoryNodeReferenceIndex txBody = + fromIntegral @Int @Integer $ findIndexReference dirNodeRef txBody + + -- The redeemer for the global script based on whether a dirctory node + -- exists with the programmable token symbol + programmableLogicGlobalRedeemer txBody = + if key dirNodeDat == programmableTokenSymbol + -- TODO: extend to allow multiple proofs, onchain allows it + then TransferAct [TokenExists $ directoryNodeReferenceIndex txBody] + else TransferAct [TokenDoesNotExist $ directoryNodeReferenceIndex txBody] + + programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody) + + addReference (uIn paramsTxIn) -- Protocol Params TxIn + addReference dirNodeRef -- Directory Node TxIn + traverse_ (\tin -> spendPlutusInlineDatum tin baseSpendingScript ()) tokenTxIns + addWithdrawalWithTxBody -- Add the global script witness to the transaction + (C.makeStakeAddress nid globalStakeCred) + (C.Quantity 0) + $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness + +{- Seize a programmable token from a user address to an issuer address. The + outputs address will be that of the issuer retrieved from @issuerTxOut@. + Throws if the payment credentials of the issuer output does not match the + programmable logic payment credential. + + IMPORTANT: It is the caller's responsibility to + ensure that the specific issuer logic stake script witness is included in the + final transaction. + + NOTE: Seems the issuer is only able to seize 1 UTxO at a time. + In the future we should allow multiple UTxOs in 1 Tx. +-} +seizeProgrammableToken :: forall a env era m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> UTxODat era a -> C.PolicyId -> [UTxODat era DirectorySetNode] -> m () +seizeProgrammableToken UTxODat{uIn = paramsTxIn} UTxODat{uIn = seizingTxIn, uOut = seizingTxOut} seizingTokenPolicyId directoryList = Utils.inBabbage @era $ do + nid <- queryNetworkId + globalStakeScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv) + baseSpendingScript <- asks (Env.dsProgrammableLogicBaseScript . Env.directoryEnv) + + let globalStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 globalStakeScript + + -- Finds the directory node entry that references the programmable token symbol + dirNodeRef <- + maybe (error "Cannot seize non-programmable token. Entry does not exist in directoryList") (pure . uIn) $ + find (isNodeWithProgrammableSymbol (transPolicyId seizingTokenPolicyId)) directoryList + + -- destStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential seizeDestinationCred + let + -- issuerDestinationAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue destStakeCred) + + (seizedAddr, remainingValue) = case seizingTxOut of + (C.TxOut a v _ _) -> + let (seized, other) = + partition + ( \case + (C.AdaAssetId, _q) -> False + (C.AssetId a _, _q) -> a == seizingTokenPolicyId + ) + $ toList $ C.txOutValueToValue v + in (a, fromList other) + + remainingTxOutValue = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra remainingValue + + seizedOutput = C.TxOut seizedAddr remainingTxOutValue C.TxOutDatumNone C.ReferenceScriptNone + + -- Finds the index of the directory node reference in the transaction ref + -- inputs + directoryNodeReferenceIndex txBody = + fromIntegral @Int @Integer $ findIndexReference dirNodeRef txBody + + -- Finds the index of the issuer input in the transaction body + seizingInputIndex txBody = + fromIntegral @Int @Integer $ findIndexSpending seizingTxIn txBody + + -- Finds the index of the issuer seized output in the transaction body + seizingOutputIndex txBody = + fromIntegral @Int @Integer $ fst $ fromJust (find ((== seizedOutput) . snd ) $ zip [0 ..] $ txBody ^. L.txOuts) + + -- The seizing redeemer for the global script + programmableLogicGlobalRedeemer txBody = + SeizeAct + { plgrSeizeInputIdx = seizingInputIndex txBody, + plgrSeizeOutputIdx = seizingOutputIndex txBody, + plgrDirectoryNodeIdx = directoryNodeReferenceIndex txBody + } + + programmableGlobalWitness txBody = buildScriptWitness globalStakeScript C.NoScriptDatumForStake (programmableLogicGlobalRedeemer txBody) + + prependTxOut seizedOutput + addReference paramsTxIn -- Protocol Params TxIn + addReference dirNodeRef -- Directory Node TxIn + spendPlutusInlineDatum seizingTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase + -- QUESTION: why do we have to spend an issuer output? + -- spendPlutusInlineDatum issuerTxIn baseSpendingScript () -- Redeemer is ignored in programmableLogicBase + addWithdrawalWithTxBody -- Add the global script witness to the transaction + (C.makeStakeAddress nid globalStakeCred) + (C.Quantity 0) + $ C.ScriptWitness C.ScriptWitnessForStakeAddr . programmableGlobalWitness + + -- TODO: check that the issuerTxOut is at a programmable logic payment credential +checkIssuerAddressIsProgLogicCred :: forall era ctx m. ( MonadBuildTx era m) => C.PaymentCredential -> C.TxOut ctx era -> m () +checkIssuerAddressIsProgLogicCred _progLogicCred (C.TxOut (C.AddressInEra _ (C.ShelleyAddress _ _pcred _stakeRef)) _ _ C.ReferenceScriptNone) = + pure () +checkIssuerAddressIsProgLogicCred _ _ = error "Issuer address is not a programmable logic credential" + +isNodeWithProgrammableSymbol :: forall era. CurrencySymbol -> UTxODat era DirectorySetNode -> Bool +isNodeWithProgrammableSymbol programmableTokenSymbol (uDatum -> dat) = key dat == programmableTokenSymbol diff --git a/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs new file mode 100644 index 0000000..79efd70 --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/ProtocolParams.hs @@ -0,0 +1,61 @@ +module Wst.Offchain.BuildTx.ProtocolParams ( + mintProtocolParams, + getProtocolParamsGlobalInline +) where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Monad.Reader (MonadReader, asks) +import Convex.BuildTx (MonadBuildTx, mintPlutus, prependTxOut, + spendPublicKeyOutput) +import Convex.Class (MonadBlockchain (..)) +import Convex.PlutusLedger.V1 (unTransAssetName) +import Convex.Scripts (fromHashableScriptData, toHashableScriptData) +import Convex.Utils qualified as Utils +import GHC.Exts (IsList (..)) +import SmartTokens.Types.Constants (protocolParamsToken) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Scripts (protocolParamsMintingScript, + protocolParamsSpendingScript, scriptPolicyIdV3) + +protocolParamsTokenC :: C.AssetName +protocolParamsTokenC = unTransAssetName protocolParamsToken + +{-| Mint the protocol parameters NFT and place it in the output locked by 'protocolParamsSpendingScript' +-} +mintProtocolParams :: forall era env m. (MonadReader env m, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBuildTx era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBlockchain era m) => m () +mintProtocolParams = Utils.inBabbage @era $ do + txIn <- asks (Env.dsTxIn . Env.directoryEnv) + params <- asks (Env.globalParams . Env.directoryEnv) + netId <- queryNetworkId + let + mintingScript = protocolParamsMintingScript txIn + + policyId = scriptPolicyIdV3 mintingScript + + val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra + $ fromList [(C.AssetId policyId protocolParamsTokenC, 1)] + + addr = + C.makeShelleyAddressInEra + C.shelleyBasedEra + netId + (C.PaymentCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 protocolParamsSpendingScript) + C.NoStakeAddress + + -- Should contain directoryNodeCS and progLogicCred fields + dat = C.TxOutDatumInline C.babbageBasedEra $ toHashableScriptData params + + output :: C.TxOut C.CtxTx era + output = C.TxOut addr val dat C.ReferenceScriptNone + + spendPublicKeyOutput txIn + mintPlutus mintingScript () protocolParamsTokenC 1 + prependTxOut output + +getProtocolParamsGlobalInline :: C.InAnyCardanoEra (C.TxOut C.CtxTx) -> Maybe ProgrammableLogicGlobalParams +getProtocolParamsGlobalInline (C.InAnyCardanoEra _ (C.TxOut _ _ dat _)) = + case dat of + C.TxOutDatumInline _era (fromHashableScriptData -> Just d) -> Just d + _ -> Nothing diff --git a/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs new file mode 100644 index 0000000..853bc08 --- /dev/null +++ b/src/lib/Wst/Offchain/BuildTx/TransferLogic.hs @@ -0,0 +1,342 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Wst.Offchain.BuildTx.TransferLogic + ( transferSmartTokens, + issueSmartTokens, + seizeSmartTokens, + initBlacklist, + insertBlacklistNode, + paySmartTokensToDestination + ) +where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens (over, (^.)) +import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Reader (MonadReader, asks) +import Convex.BuildTx (MonadBuildTx (addTxBuilder), TxBuilder (TxBuilder), + addRequiredSignature, addScriptWithdrawal, + addWithdrawalWithTxBody, buildScriptWitness, + findIndexReference, mintPlutus, payToAddress, + prependTxOut, spendPlutusInlineDatum) +import Convex.CardanoApi.Lenses qualified as L +import Convex.Class (MonadBlockchain (queryNetworkId)) +import Convex.PlutusLedger.V1 (transCredential, transPolicyId, + transStakeCredential, unTransStakeCredential) +import Convex.Scripts qualified as C +import Convex.Utils qualified as Utils +import Convex.Utxos (UtxoSet (UtxoSet)) +import Convex.Wallet (selectMixedInputsCovering) +import Data.Foldable (maximumBy) +import Data.Function (on) +import Data.List (nub, sort) +import Data.Monoid (Last (..)) +import GHC.Exts (IsList (..)) +import PlutusLedgerApi.Data.V3 (Credential (..), PubKeyHash (PubKeyHash), + ScriptHash (..)) +import PlutusLedgerApi.V3 qualified as PlutusTx +import SmartTokens.Contracts.ExampleTransferLogic (BlacklistProof (..)) +import SmartTokens.Types.ProtocolParams +import SmartTokens.Types.PTokenDirectory (BlacklistNode (..), + DirectorySetNode (..)) +import Wst.AppError (AppError (TransferBlacklistedCredential)) +import Wst.Offchain.BuildTx.ProgrammableLogic (IssueNewTokenArgs (..), + issueProgrammableToken, + seizeProgrammableToken, + transferProgrammableToken) +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query (UTxODat (..)) +import Wst.Offchain.Scripts (scriptPolicyIdV3) + +intaFromEnv :: forall env m. (MonadReader env m, Env.HasTransferLogicEnv env)=> m IssueNewTokenArgs +intaFromEnv = do + Env.TransferLogicEnv{Env.tleIssuerScript, Env.tleMintingScript, Env.tleTransferScript} <- asks Env.transferLogicEnv + pure $ IssueNewTokenArgs + { intaTransferLogic= tleTransferScript + , intaMintingLogic= tleMintingScript + , intaIssuerLogic= tleIssuerScript + } + + +{- +>>> _printTerm $ unsafeEvalTerm NoTracing (pconstant blacklistInitialNode) +"program\n 1.0.0\n (List [B #, B #ffffffffffffffffffffffffffffffffffffffffffffffffffffffff])" +-} +blacklistInitialNode :: BlacklistNode +blacklistInitialNode = + BlacklistNode + { blnNext= "" + , blnKey= ""} + +initBlacklist :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +initBlacklist = Utils.inBabbage @era $ do + nid <- queryNetworkId + + -- create blacklist head node data + let blacklistInitialNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData blacklistInitialNode + + -- mint blacklist policy token + mintingScript <- asks (Env.tleBlacklistMintingScript . Env.transferLogicEnv) + let assetName = C.AssetName "" + quantity = 1 + + mintPlutus mintingScript () assetName quantity + + -- send blacklist output to blacklist spending script + spendingScript <- asks (Env.tleBlacklistSpendingScript . Env.transferLogicEnv) + let policyId = scriptPolicyIdV3 mintingScript + spendingHash = C.hashScript $ C.PlutusScript C.PlutusScriptV3 spendingScript + addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid (C.PaymentCredentialByScript spendingHash) C.NoStakeAddress + val = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(C.AssetId policyId assetName, quantity)] + txout = C.TxOut addr val blacklistInitialNodeDatum C.ReferenceScriptNone + + prependTxOut txout + + -- add operator signature + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + addRequiredSignature opPkh + +insertBlacklistNode :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => C.PaymentCredential -> [UTxODat era BlacklistNode]-> m () +insertBlacklistNode cred blacklistNodes = Utils.inBabbage @era $ do + -- mint new blacklist token + mintingScript <- asks (Env.tleBlacklistMintingScript . Env.transferLogicEnv) + let newAssetName = C.AssetName $ case transCredential cred of + PubKeyCredential (PubKeyHash s) -> PlutusTx.fromBuiltin s + ScriptCredential (ScriptHash s) -> PlutusTx.fromBuiltin s + quantity = 1 + mintPlutus mintingScript () newAssetName quantity + + let + + -- find the node to insert on + UTxODat {uIn = prevNodeRef,uOut = (C.TxOut prevAddr prevVal _ _), uDatum = prevNode} = + maximumBy (compare `on` (blnKey . uDatum)) $ + filter ((<= unwrapCredential (transCredential cred)) . blnKey . uDatum) blacklistNodes + + -- create new blacklist node data + newNode = BlacklistNode {blnNext=blnNext prevNode, blnKey= unwrapCredential (transCredential cred)} + newNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData newNode + newNodeVal = C.TxOutValueShelleyBased C.shelleyBasedEra $ C.toLedgerValue @era C.maryBasedEra $ fromList [(C.AssetId (scriptPolicyIdV3 mintingScript) newAssetName, quantity)] + newNodeOutput = C.TxOut prevAddr newNodeVal newNodeDatum C.ReferenceScriptNone + + -- update the previous node to point to the new node + newPrevNode = prevNode {blnNext=unwrapCredential (transCredential cred)} + newPrevNodeDatum = C.TxOutDatumInline C.babbageBasedEra $ C.toHashableScriptData newPrevNode + newPrevNodeOutput = C.TxOut prevAddr prevVal newPrevNodeDatum C.ReferenceScriptNone + + -- spend previous node + spendingScript <- asks (Env.tleBlacklistSpendingScript . Env.transferLogicEnv) + spendPlutusInlineDatum prevNodeRef spendingScript () + -- set previous node output + prependTxOut newPrevNodeOutput + -- set new node output + prependTxOut newNodeOutput + + -- add operator signature + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + addRequiredSignature opPkh + +{-| Add a smart token output that locks the given value, +addressed to the payment credential +-} +paySmartTokensToDestination :: forall era env m. (MonadBuildTx era m, MonadReader env m, Env.HasDirectoryEnv env, MonadBlockchain era m, C.IsBabbageBasedEra era) => (C.AssetName, C.Quantity) -> C.PolicyId -> C.PaymentCredential -> m () +paySmartTokensToDestination (an, q) issuedPolicyId destinationCred = Utils.inBabbage @era $ do + nid <- queryNetworkId + -- TODO: check if there is a better way to achieve: C.PaymentCredential -> C.StakeCredential + stakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred + directoryEnv <- asks Env.directoryEnv + let progLogicBaseCred = Env.programmableLogicBaseCredential directoryEnv + let value = fromList [(C.AssetId issuedPolicyId an, q)] + addr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue stakeCred) + + payToAddress addr value + +issueSmartTokens :: forall era env m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env) => UTxODat era ProgrammableLogicGlobalParams -> (C.AssetName, C.Quantity) -> [UTxODat era DirectorySetNode] -> C.PaymentCredential -> m C.AssetId +issueSmartTokens paramsTxOut (an, q) directoryList destinationCred = Utils.inBabbage @era $ do + inta <- intaFromEnv + issuedPolicyId <- issueProgrammableToken paramsTxOut (an, q) inta directoryList + + + addIssueWitness + -- payToAddress addr value + paySmartTokensToDestination (an, q) issuedPolicyId destinationCred + pure $ C.AssetId issuedPolicyId an + +transferSmartTokens :: forall env era a m. (MonadReader env m, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m, Env.HasOperatorEnv era env, MonadError (AppError era) m) => UTxODat era ProgrammableLogicGlobalParams -> C.PaymentCredential -> [UTxODat era BlacklistNode] -> [UTxODat era DirectorySetNode] -> [UTxODat era a] -> (C.AssetId, C.Quantity) -> C.PaymentCredential -> m () +transferSmartTokens paramsTxIn userCred blacklistNodes directoryList spendingUserOutputs (assetId, q) destinationCred = Utils.inBabbage @era $ do + nid <- queryNetworkId + progLogicBaseCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + + -- Find sufficient inputs to cover the transfer + let userOutputsMap = fromList $ map (\UTxODat {uIn, uOut, uDatum} -> (uIn, (C.inAnyCardanoEra (C.cardanoEra @era) uOut, uDatum))) spendingUserOutputs + (totalVal, txins) <- maybe (error "insufficient funds for transfer") pure $ selectMixedInputsCovering (UtxoSet userOutputsMap) [(assetId, q)] + + -- Spend the outputs via programmableLogicBaseScript + let programmablePolicyId = case assetId of + C.AssetId policyId _ -> policyId + C.AdaAssetId -> error "Ada is not programmable" + + transferProgrammableToken paramsTxIn txins (transPolicyId programmablePolicyId) directoryList -- Invoking the programmableBase and global scripts + addTransferWitness blacklistNodes userCred -- Proof of non-membership of the blacklist + + -- Send outputs to destinationCred + destStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred + let destinationVal :: C.Value = fromList [(assetId, q)] + destinationAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue destStakeCred) + payToAddress destinationAddress destinationVal + + -- Return change to the spendingUserOutputs address + srcStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential userCred + let returnVal = + C.TxOutValueShelleyBased C.shelleyBasedEra $ + C.toLedgerValue @era C.maryBasedEra $ + fromList [(assetId, C.selectAsset totalVal assetId - q)] + returnAddr = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue srcStakeCred) + returnOutput = C.TxOut returnAddr returnVal C.TxOutDatumNone C.ReferenceScriptNone + prependTxOut returnOutput -- Add the seized output to the transaction + +seizeSmartTokens :: forall env era a m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, Env.HasDirectoryEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => UTxODat era ProgrammableLogicGlobalParams -> UTxODat era a -> C.PaymentCredential -> [UTxODat era DirectorySetNode] -> m () +seizeSmartTokens paramsTxIn seizingTxo destinationCred directoryList = Utils.inBabbage @era $ do + nid <- queryNetworkId + + let -- NOTE: Assumes only a single programmable token per UTxO is allowed + Last maybeProgAsset = case uOut seizingTxo of + (C.TxOut _a v _d _r) -> + foldMap + ( \case + (C.AssetId pid an, q) -> Last (Just (pid, an, q)) + (C.AdaAssetId, _q) -> Last Nothing + ) + (toList $ C.txOutValueToValue v) + + (progTokenPolId, an, q) <- maybe (error "No programmable token found in seizing transaction") pure maybeProgAsset + seizeProgrammableToken paramsTxIn seizingTxo progTokenPolId directoryList + addSeizeWitness + + progLogicBaseCred <- asks (Env.programmableLogicBaseCredential . Env.directoryEnv) + destStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential destinationCred + let + destinationAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid progLogicBaseCred (C.StakeAddressByValue destStakeCred) + + -- NOTE: Assumes only a single programmable token per UTxO is allowed + seizedVal = fromList [(C.AssetId progTokenPolId an, q)] + + -- Send seized funds to destinationCred + payToAddress destinationAddress seizedVal + +addIssueWitness :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +addIssueWitness = Utils.inBabbage @era $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + mintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) + let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 mintingScript + addRequiredSignature opPkh + addScriptWithdrawal sh 0 $ buildScriptWitness mintingScript C.NoScriptDatumForStake () + +{-| Extracts the credentials that can be used for a transfer from the transaction body +-} +transferWitnesses :: C.TxBodyContent v era -> [Credential] +transferWitnesses txBody = + let wdrls = case txBody ^. L.txWithdrawals of + -- Maybe `sort` here is redundant if txWithdrawals are already sorted + C.TxWithdrawals _ wdrls' -> sort $ map (\(stkAddr,_,_) -> transStakeCredential $ C.stakeAddressCredential stkAddr) wdrls' + _ -> [] + + signatories = case txBody ^. L.txExtraKeyWits of + C.TxExtraKeyWitnesses _ pkhs -> map (transCredential . C.PaymentCredentialByKey) pkhs + _ -> [] + + in wdrls <> signatories + +data FindProofResult era = + NoBlacklistNodes -- TODO: Use NonEmpty list to avoid this + | CredentialBlacklisted (UTxODat era BlacklistNode) -- ^ A node containing exactly the credential was found. (Negative result, transfer not OK) + | CredentialNotBlacklisted (UTxODat era BlacklistNode) -- ^ A node was found that spans the credential but does not match it exactly. (Positive result, transfer OK) + +{-| Find the blacklist node that covers the credential but does not match it exactly +-} +tryFindProof :: [UTxODat era BlacklistNode] -> Credential -> UTxODat era BlacklistNode +tryFindProof blacklistNodes cred = + case findProof blacklistNodes cred of + CredentialNotBlacklisted r -> r + _ -> error $ "tryFindProof failed for " <> show cred + +{-| Find the blacklist node that covers the credential. +-} +findProof :: [UTxODat era BlacklistNode] -> Credential -> FindProofResult era +findProof [] _cred = NoBlacklistNodes +findProof blacklistNodes cred = + let node@UTxODat {uDatum = blnNodeDatum} + = maximumBy (compare `on` (blnKey . uDatum)) $ + filter ((<= unwrapCredential cred) . blnKey . uDatum) blacklistNodes + in if blnKey blnNodeDatum == unwrapCredential cred + then CredentialBlacklisted node + else CredentialNotBlacklisted node + +{-| Check that the credential is not blacklisted. Throw an error if the + credential is blacklisted. +-} +checkNotBlacklisted :: forall era m. MonadError (AppError era) m => [UTxODat era BlacklistNode] -> Credential -> m () +checkNotBlacklisted nodes cred = case findProof nodes cred of + CredentialNotBlacklisted{} -> pure () + _ -> throwError (TransferBlacklistedCredential cred) + +{-| Add a proof that the user is allowed to transfer programmable tokens. +Uses the user from 'HasOperatorEnv env'. Fails if the user is blacklisted. +-} +addTransferWitness :: forall env era m. (MonadError (AppError era) m, MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => [UTxODat era BlacklistNode] -> C.PaymentCredential -> m () +addTransferWitness blacklistNodes clientCred = Utils.inBabbage @era $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) -- In this case 'operator' is the user + nid <- queryNetworkId + transferScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) + + let + transferStakeCred = C.StakeCredentialByScript $ C.hashScript $ C.PlutusScript C.PlutusScriptV3 transferScript + + -- Finds the index of the blacklist node in the reference scripts + findWitnessReferenceIndex txBody cred = + let UTxODat {uIn, uDatum = blnNodeDatum} = tryFindProof blacklistNodes cred + in fromIntegral @Int @Integer $ findIndexReference uIn txBody + + -- Maps the credential to the index of the blacklist node in the reference scripts + witnessReferences txBody = map (uIn . tryFindProof blacklistNodes) $ transferWitnesses txBody + + -- Maps the credential to the index of the blacklist node in the reference scripts and wraps in redeemer + transferRedeemer txBody = map (NonmembershipProof . findWitnessReferenceIndex txBody) $ transferWitnesses txBody + + -- Builds the script witness for the transfer + transferStakeWitness txBody = buildScriptWitness transferScript C.NoScriptDatumForStake (transferRedeemer txBody) + + -- Check that none of the witnesses are on the blacklist + -- This means we're traversing the list of blacklist nodes an additional time. + -- But here is the only place where we can use MonadError. So we have to do it + -- here to allow the client code to handle the error properly. + checkNotBlacklisted blacklistNodes (transCredential $ C.PaymentCredentialByKey opPkh) + + addRequiredSignature opPkh + addReferencesWithTxBody witnessReferences + addWithdrawalWithTxBody -- Add the global script witness to the transaction + (C.makeStakeAddress nid transferStakeCred) + (C.Quantity 0) + $ C.ScriptWitness C.ScriptWitnessForStakeAddr . transferStakeWitness + +addReferencesWithTxBody :: (MonadBuildTx era m, C.IsBabbageBasedEra era) => (C.TxBodyContent C.BuildTx era -> [C.TxIn]) -> m () +addReferencesWithTxBody f = + addTxBuilder (TxBuilder $ \body -> over (L.txInsReference . L._TxInsReferenceIso) (nub . (f body <>))) + + +addSeizeWitness :: forall env era m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, C.IsBabbageBasedEra era, MonadBlockchain era m, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadBuildTx era m) => m () +addSeizeWitness = Utils.inBabbage @era $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + seizeScript <- asks (Env.tleIssuerScript . Env.transferLogicEnv) + let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV3 seizeScript + addRequiredSignature opPkh + addScriptWithdrawal sh 0 $ buildScriptWitness seizeScript C.NoScriptDatumForStake () + +unwrapCredential :: Credential -> PlutusTx.BuiltinByteString +unwrapCredential = \case + PubKeyCredential (PubKeyHash s) -> s + ScriptCredential (ScriptHash s) -> s diff --git a/src/lib/Wst/Offchain/Endpoints/Deployment.hs b/src/lib/Wst/Offchain/Endpoints/Deployment.hs new file mode 100644 index 0000000..55a587f --- /dev/null +++ b/src/lib/Wst/Offchain/Endpoints/Deployment.hs @@ -0,0 +1,196 @@ +{-| Deploy the directory and global params +-} +module Wst.Offchain.Endpoints.Deployment( + deployTx, + deployBlacklistTx, + insertNodeTx, + issueProgrammableTokenTx, + issueSmartTokensTx, + transferSmartTokensTx, + insertBlacklistNodeTx, + blacklistCredentialTx, + seizeCredentialAssetsTx, +) where + +import Cardano.Api (Quantity) +import Cardano.Api.Shelley qualified as C +import Control.Monad (when) +import Control.Monad.Except (MonadError) +import Control.Monad.Reader (MonadReader, asks) +import Convex.BuildTx (payToAddress) +import Convex.BuildTx qualified as BuildTx +import Convex.Class (MonadBlockchain, MonadUtxoQuery) +import Convex.CoinSelection qualified +import Data.Foldable (maximumBy) +import Data.Function (on) +import SmartTokens.Types.PTokenDirectory (DirectorySetNode (..)) +import Wst.AppError (AppError) +import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (inaNewKey)) +import Wst.Offchain.BuildTx.DirectorySet qualified as BuildTx +import Wst.Offchain.BuildTx.ProgrammableLogic qualified as BuildTx +import Wst.Offchain.BuildTx.ProtocolParams qualified as BuildTx +import Wst.Offchain.BuildTx.TransferLogic qualified as BuildTx +import Wst.Offchain.BuildTx.TransferLogic qualified as TL +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query (UTxODat (..)) +import Wst.Offchain.Query qualified as Query + +{-| Build a transaction that deploys the directory and global params. Returns the +transaction and the 'TxIn' that was selected for the one-shot NFTs. +-} +deployTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era, C.TxIn) +deployTx = do + (txi, _) <- Env.selectOperatorOutput + opEnv <- asks Env.operatorEnv + (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withDirectoryFor txi + $ Env.balanceTxEnv_ + $ BuildTx.mintProtocolParams >> BuildTx.initDirectorySet + pure (Convex.CoinSelection.signBalancedTxBody [] tx, txi) + +{-| Build a transaction that inserts a node into the directory +-} +insertNodeTx :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasDirectoryEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadUtxoQuery m) => InsertNodeArgs -> m (C.Tx era) +insertNodeTx args = do + -- 1. Find the head node + directoryList <- Query.registryNodes @era + -- FIXME: Error handling. And how can we actually identify the head node if the query returns more than one? + let headNode@UTxODat{uDatum = dirNodeDat} = + maximumBy (compare `on` (key . uDatum)) $ + filter ((<= inaNewKey args) . key . uDatum) directoryList + when (key dirNodeDat == inaNewKey args) $ error "Node already exists" + + -- 2. Find the global parameter node + paramsNode <- Query.globalParamsNode @era + (tx, _) <- Env.balanceTxEnv_ (BuildTx.insertDirectoryNode paramsNode headNode args) + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +{-| Build a transaction that issues a progammable token +-} +issueProgrammableTokenTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => BuildTx.IssueNewTokenArgs -- ^ credentials of the token + -> C.AssetName -- ^ Name of the asset + -> Quantity -- ^ Amount of tokens to be minted + -> m (C.Tx era) +issueProgrammableTokenTx issueTokenArgs assetName quantity = do + directory <- Query.registryNodes @era + paramsNode <- Query.globalParamsNode @era + (tx, _) <- Env.balanceTxEnv_ $ do + polId <- BuildTx.issueProgrammableToken paramsNode (assetName, quantity) issueTokenArgs directory + Env.operatorPaymentCredential + >>= BuildTx.paySmartTokensToDestination (assetName, quantity) polId + let hsh = C.hashScript (C.PlutusScript C.plutusScriptVersion $ BuildTx.intaMintingLogic issueTokenArgs) + BuildTx.addScriptWithdrawal hsh 0 $ BuildTx.buildScriptWitness (BuildTx.intaMintingLogic issueTokenArgs) C.NoScriptDatumForStake () + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +deployBlacklistTx :: (MonadReader env m, Env.HasOperatorEnv era env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era) => m (C.Tx era) +deployBlacklistTx = do + opEnv <- asks Env.operatorEnv + (tx, _) <- Env.withEnv $ Env.withOperator opEnv $ Env.withTransferFromOperator + $ Env.balanceTxEnv_ BuildTx.initBlacklist + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +insertBlacklistNodeTx :: forall era env m. (MonadReader env m, Env.HasOperatorEnv era env, Env.HasTransferLogicEnv env, MonadBlockchain era m, MonadError (AppError era) m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era, MonadUtxoQuery m) => C.PaymentCredential -> m (C.Tx era) +insertBlacklistNodeTx cred = do + blacklist <- Query.blacklistNodes @era + (tx, _) <- Env.balanceTxEnv_ (BuildTx.insertBlacklistNode cred blacklist) + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +{-| Build a transaction that issues a progammable token +-} +issueSmartTokensTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasDirectoryEnv env + , Env.HasTransferLogicEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.AssetName -- ^ Name of the asset + -> Quantity -- ^ Amount of tokens to be minted + -> C.PaymentCredential -- ^ Destination credential + -> m (C.Tx era, C.AssetId) +issueSmartTokensTx assetName quantity destinationCred = do + directory <- Query.registryNodes @era + paramsNode <- Query.globalParamsNode @era + ((tx, _), aid) <- Env.balanceTxEnv $ do + BuildTx.issueSmartTokens paramsNode (assetName, quantity) directory destinationCred + pure (Convex.CoinSelection.signBalancedTxBody [] tx, aid) + +{-| Build a transaction that issues a progammable token +-} +transferSmartTokensTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasDirectoryEnv env + , Env.HasTransferLogicEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.PaymentCredential -- ^ Source/User credential + -> C.AssetId -- ^ AssetId to transfer + -> Quantity -- ^ Amount of tokens to be minted + -> C.PaymentCredential -- ^ Destination credential + -> m (C.Tx era) +transferSmartTokensTx srcCred assetId quantity destCred = do + directory <- Query.registryNodes @era + blacklist <- Query.blacklistNodes @era + userOutputsAtProgrammable <- Query.userProgrammableOutputs srcCred + paramsTxIn <- Query.globalParamsNode @era + (tx, _) <- Env.balanceTxEnv_ $ do + BuildTx.transferSmartTokens paramsTxIn srcCred blacklist directory userOutputsAtProgrammable (assetId, quantity) destCred + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +blacklistCredentialTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasTransferLogicEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.PaymentCredential -- ^ Source/User credential + -> m (C.Tx era) +blacklistCredentialTx sanctionedCred = do + blacklist <- Query.blacklistNodes @era + (tx, _) <- Env.balanceTxEnv_ $ do + BuildTx.insertBlacklistNode sanctionedCred blacklist + pure (Convex.CoinSelection.signBalancedTxBody [] tx) + +seizeCredentialAssetsTx :: forall era env m. + ( MonadReader env m + , Env.HasOperatorEnv era env + , Env.HasTransferLogicEnv env + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => C.PaymentCredential -- ^ Source/User credential + -> m (C.Tx era) +seizeCredentialAssetsTx sanctionedCred = do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + directory <- Query.registryNodes @era + seizeTxo <- head <$> Query.userProgrammableOutputs sanctionedCred + paramsTxIn <- Query.globalParamsNode @era + (tx, _) <- Env.balanceTxEnv_ $ do + BuildTx.seizeSmartTokens paramsTxIn seizeTxo (C.PaymentCredentialByKey opPkh) directory + pure (Convex.CoinSelection.signBalancedTxBody [] tx) diff --git a/src/lib/Wst/Offchain/Env.hs b/src/lib/Wst/Offchain/Env.hs new file mode 100644 index 0000000..7aee006 --- /dev/null +++ b/src/lib/Wst/Offchain/Env.hs @@ -0,0 +1,391 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} + +{-| Transaction building environment +-} +module Wst.Offchain.Env( + -- * Operator environment + HasOperatorEnv(..), + OperatorEnv(..), + loadOperatorEnv, + loadOperatorEnvFromAddress, + operatorPaymentCredential, + + -- ** Using the operator environment + selectOperatorOutput, + balanceTxEnv, + balanceTxEnv_, + + -- * Directory environment + HasDirectoryEnv(..), + DirectoryEnv(..), + mkDirectoryEnv, + programmableLogicStakeCredential, + programmableLogicBaseCredential, + directoryNodePolicyId, + protocolParamsPolicyId, + globalParams, + + + -- * Transfer logic environment + TransferLogicEnv(..), + HasTransferLogicEnv(..), + mkTransferLogicEnv, + addTransferEnv, + withTransfer, + withTransferFor, + withTransferFromOperator, + + -- * Runtime data + RuntimeEnv(..), + HasRuntimeEnv(..), + loadRuntimeEnv, + + -- * Combined environment + CombinedEnv(..), + empty, + withEnv, + addDirectoryEnvFor, + addDirectoryEnv, + withDirectory, + withDirectoryFor, + addRuntimeEnv, + withRuntime, + addOperatorEnv, + withOperator +) where + +import Blammo.Logging (Logger) +import Blammo.Logging.Logger (HasLogger (..), newLogger) +import Blammo.Logging.LogSettings.Env qualified as LogSettingsEnv +import Blockfrost.Auth (mkProject) +import Blockfrost.Client.Auth qualified as Blockfrost +import Cardano.Api (PlutusScript, PlutusScriptV3, UTxO) +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Control.Lens (makeLensesFor) +import Control.Lens qualified as L +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT) +import Convex.BuildTx (BuildTxT) +import Convex.BuildTx qualified as BuildTx +import Convex.Class (MonadBlockchain, MonadUtxoQuery (..), + queryProtocolParameters, utxosByPaymentCredential) +import Convex.CoinSelection qualified as CoinSelection +import Convex.PlutusLedger.V1 (transCredential, transPolicyId) +import Convex.Utils (mapError) +import Convex.Utxos (BalanceChanges) +import Convex.Utxos qualified as Utxos +import Convex.Wallet.Operator (returnOutputFor) +import Data.Functor.Identity (Identity (..)) +import Data.Map qualified as Map +import Data.Maybe (listToMaybe) +import Data.Proxy (Proxy (..)) +import Data.Text qualified as Text +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams (..)) +import System.Environment qualified +import Wst.AppError (AppError (..)) +import Wst.Offchain.Scripts (blacklistMintingScript, blacklistSpendingScript, + directoryNodeMintingScript, + directoryNodeSpendingScript, freezeTransferScript, + permissionedTransferScript, + programmableLogicBaseScript, + programmableLogicGlobalScript, + protocolParamsMintingScript, scriptPolicyIdV3) + +{-| Environments that have an 'OperatorEnv' +-} +class HasOperatorEnv era e | e -> era where + operatorEnv :: e -> OperatorEnv era + +instance HasOperatorEnv era (OperatorEnv era) where + operatorEnv = id + +{-| Information needed to build transactions +-} +data OperatorEnv era = + OperatorEnv + { bteOperator :: (C.Hash C.PaymentKey, C.StakeAddressReference) -- ^ Payment and stake credential, used for generating return outputs + , bteOperatorUtxos :: UTxO era -- ^ UTxOs owned by the operator, available for spending + } + +{-| Get the operator's payment credential from the 'env' +-} +operatorPaymentCredential :: (MonadReader env m, HasOperatorEnv era env) => m C.PaymentCredential +operatorPaymentCredential = asks (C.PaymentCredentialByKey . fst . bteOperator . operatorEnv) + +{-| Populate the 'OperatorEnv' with UTxOs locked by the payment credential +-} +loadOperatorEnv :: (MonadUtxoQuery m, C.IsBabbageBasedEra era) => C.Hash C.PaymentKey -> C.StakeAddressReference -> m (OperatorEnv era) +loadOperatorEnv paymentCredential stakeCredential = do + let bteOperator = (paymentCredential, stakeCredential) + bteOperatorUtxos <- Utxos.toApiUtxo <$> utxosByPaymentCredential (C.PaymentCredentialByKey paymentCredential) + pure OperatorEnv{bteOperator, bteOperatorUtxos} + +loadOperatorEnvFromAddress :: (MonadUtxoQuery m, C.IsBabbageBasedEra era) => C.Address C.ShelleyAddr -> m (OperatorEnv era) +loadOperatorEnvFromAddress = \case + (C.ShelleyAddress _ntw (C.fromShelleyPaymentCredential -> C.PaymentCredentialByKey pmt) stakeRef) -> + loadOperatorEnv pmt (C.fromShelleyStakeReference stakeRef) + _ -> error "Expected public key address" -- FIXME: proper error + +{-| Select an output owned by the operator +-} +selectOperatorOutput :: (MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m) => m (C.TxIn, C.TxOut C.CtxUTxO era) +selectOperatorOutput = asks (listToMaybe . Map.toList . C.unUTxO . bteOperatorUtxos . operatorEnv) >>= \case + Nothing -> throwError OperatorNoUTxOs + Just k -> pure k + +{-| Balance a transaction using the operator's funds and return output +-} +balanceTxEnv_ :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m (C.BalancedTxBody era, BalanceChanges) +balanceTxEnv_ btx = do + OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv + params <- queryProtocolParameters + txBuilder <- BuildTx.execBuildTxT $ btx >> BuildTx.setMinAdaDepositAll params + -- TODO: change returnOutputFor to consider the stake address reference + -- (needs to be done in sc-tools) + output <- returnOutputFor (C.PaymentCredentialByKey $ fst bteOperator) + mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) + +{-| Balance a transaction using the operator's funds and return output +-} +balanceTxEnv :: forall era env a m. (MonadBlockchain era m, MonadReader env m, HasOperatorEnv era env, MonadError (AppError era) m, C.IsBabbageBasedEra era) => BuildTxT era m a -> m ((C.BalancedTxBody era, BalanceChanges), a) +balanceTxEnv btx = do + OperatorEnv{bteOperatorUtxos, bteOperator} <- asks operatorEnv + params <- queryProtocolParameters + (r, txBuilder) <- BuildTx.runBuildTxT $ btx <* BuildTx.setMinAdaDepositAll params + -- TODO: change returnOutputFor to consider the stake address reference + -- (needs to be done in sc-tools) + output <- returnOutputFor (C.PaymentCredentialByKey $ fst bteOperator) + (balBody, balChanges) <- mapError BalancingError (CoinSelection.balanceTx mempty output (Utxos.fromApiUtxo bteOperatorUtxos) txBuilder CoinSelection.TrailingChange) + pure ((balBody, balChanges), r) + + +class HasDirectoryEnv e where + directoryEnv :: e -> DirectoryEnv + +instance HasDirectoryEnv DirectoryEnv where + directoryEnv = id + +{-| Scripts related to managing the token policy directory. +All of the scripts and their hashes are determined by the 'TxIn'. +-} +data DirectoryEnv = + DirectoryEnv + { dsTxIn :: C.TxIn -- ^ The 'txIn' that we spend when deploying the protocol params and directory set + , dsDirectoryMintingScript :: PlutusScript PlutusScriptV3 + , dsDirectorySpendingScript :: PlutusScript PlutusScriptV3 + , dsProtocolParamsMintingScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicBaseScript :: PlutusScript PlutusScriptV3 + , dsProgrammableLogicGlobalScript :: PlutusScript PlutusScriptV3 + } + +mkDirectoryEnv :: C.TxIn -> DirectoryEnv +mkDirectoryEnv dsTxIn = + let dsDirectoryMintingScript = directoryNodeMintingScript dsTxIn + dsProtocolParamsMintingScript = protocolParamsMintingScript dsTxIn + dsDirectorySpendingScript = directoryNodeSpendingScript (protocolParamsPolicyId result) + dsProgrammableLogicBaseScript = programmableLogicBaseScript (programmableLogicStakeCredential result) -- Parameterized by the stake cred of the global script + dsProgrammableLogicGlobalScript = programmableLogicGlobalScript (protocolParamsPolicyId result) -- Parameterized by the CS holding protocol params datum + result = DirectoryEnv + { dsTxIn + , dsDirectoryMintingScript + , dsProtocolParamsMintingScript + , dsProgrammableLogicBaseScript + , dsProgrammableLogicGlobalScript + , dsDirectorySpendingScript + } + in result + +programmableLogicStakeCredential :: DirectoryEnv -> C.StakeCredential +programmableLogicStakeCredential = + C.StakeCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicGlobalScript + +programmableLogicBaseCredential :: DirectoryEnv -> C.PaymentCredential +programmableLogicBaseCredential = + C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript + +directoryNodePolicyId :: DirectoryEnv -> C.PolicyId +directoryNodePolicyId = scriptPolicyIdV3 . dsDirectoryMintingScript + +protocolParamsPolicyId :: DirectoryEnv -> C.PolicyId +protocolParamsPolicyId = scriptPolicyIdV3 . dsProtocolParamsMintingScript + +globalParams :: DirectoryEnv -> ProgrammableLogicGlobalParams +globalParams scripts = + ProgrammableLogicGlobalParams + { directoryNodeCS = transPolicyId (directoryNodePolicyId scripts) + , progLogicCred = transCredential (programmableLogicBaseCredential scripts) -- its the script hash of the programmable base spending script + } + +{-| Scripts related to managing the specific transfer logic +-} + +data TransferLogicEnv = + TransferLogicEnv + { tleBlacklistMintingScript :: PlutusScript PlutusScriptV3 + , tleBlacklistSpendingScript :: PlutusScript PlutusScriptV3 + , tleMintingScript :: PlutusScript PlutusScriptV3 + , tleTransferScript :: PlutusScript PlutusScriptV3 + , tleIssuerScript :: PlutusScript PlutusScriptV3 + } + +class HasTransferLogicEnv e where + transferLogicEnv :: e -> TransferLogicEnv + +instance HasTransferLogicEnv TransferLogicEnv where + transferLogicEnv = id + +{-| The 'TransferLogicEnv' with scripts that allow the given payment credential +to manage the blacklist and issue / burn tokens +-} +mkTransferLogicEnv :: C.Hash C.PaymentKey -> TransferLogicEnv +mkTransferLogicEnv cred = + let blacklistMinting = blacklistMintingScript cred + blacklistPolicy = scriptPolicyIdV3 blacklistMinting + in + TransferLogicEnv + { tleBlacklistMintingScript = blacklistMinting + , tleBlacklistSpendingScript = blacklistSpendingScript cred + , tleMintingScript = permissionedTransferScript cred + , tleTransferScript = freezeTransferScript blacklistPolicy + , tleIssuerScript = permissionedTransferScript cred + } + +data RuntimeEnv + = RuntimeEnv + { envLogger :: Logger + , envBlockfrost :: Blockfrost.Project + } + +makeLensesFor + [ ("envLogger", "logger") + , ("envBlockfrostProject", "blockfrostProject") + ] + 'RuntimeEnv + +instance HasLogger RuntimeEnv where + loggerL = logger + +-- | Load the 'RuntimeEnv' from environment variables +loadRuntimeEnv :: IO RuntimeEnv +loadRuntimeEnv = + RuntimeEnv + <$> (LogSettingsEnv.parse >>= newLogger) + <*> fmap (mkProject . Text.pack) (System.Environment.getEnv "WST_BLOCKFROST_TOKEN") + +class HasRuntimeEnv e where + runtimeEnv :: e -> RuntimeEnv + +instance HasRuntimeEnv RuntimeEnv where + runtimeEnv = id + +data CombinedEnv operatorF directoryF transferF runtimeF era = + CombinedEnv + { ceOperator :: operatorF (OperatorEnv era) + , ceDirectory :: directoryF DirectoryEnv + , ceTransfer :: transferF TransferLogicEnv + , ceRuntime :: runtimeF RuntimeEnv + } + +makeLensesFor + [("ceRuntime", "runtime")] + ''CombinedEnv + +{-| 'CombinedEnv' with no values +-} +empty :: forall era. CombinedEnv Proxy Proxy Proxy Proxy era +empty = + CombinedEnv + { ceOperator = Proxy + , ceDirectory = Proxy + , ceTransfer = Proxy + , ceRuntime = Proxy + } + +instance HasOperatorEnv era (CombinedEnv Identity d t r era) where + operatorEnv = runIdentity . ceOperator + +instance HasDirectoryEnv (CombinedEnv o Identity t r era) where + directoryEnv = runIdentity . ceDirectory + +instance HasTransferLogicEnv (CombinedEnv o d Identity r era) where + transferLogicEnv = runIdentity . ceTransfer + +instance HasRuntimeEnv (CombinedEnv o d t Identity era) where + runtimeEnv = runIdentity . ceRuntime + +_Identity :: L.Iso' (Identity a) a +_Identity = L.iso runIdentity Identity + +instance HasLogger (CombinedEnv o d t Identity era) where + loggerL = runtime . _Identity . loggerL + +{-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment +-} +addDirectoryEnvFor :: C.TxIn -> CombinedEnv o d t r era -> CombinedEnv o Identity t r era +addDirectoryEnvFor txi = addDirectoryEnv (mkDirectoryEnv txi) + +{-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment +-} +addDirectoryEnv :: DirectoryEnv -> CombinedEnv o d t r era -> CombinedEnv o Identity t r era +addDirectoryEnv de env = + env{ceDirectory = Identity de } + +withDirectory :: MonadReader (CombinedEnv o d t r era) m => DirectoryEnv -> ReaderT (CombinedEnv o Identity t r era) m a -> m a +withDirectory dir action = do + asks (addDirectoryEnv dir) + >>= runReaderT action + +withDirectoryFor :: MonadReader (CombinedEnv o d t r era) m => C.TxIn -> ReaderT (CombinedEnv o Identity t r era) m a -> m a +withDirectoryFor txi = withDirectory (mkDirectoryEnv txi) + +{-| Add a 'TransferLogicEnv' for the 'C.Hash C.PaymentKey' corresponding to the + admin hash + -} +addTransferEnv :: TransferLogicEnv -> CombinedEnv o d t r era -> CombinedEnv o d Identity r era +addTransferEnv de env = + env{ceTransfer = Identity de } + +withTransfer :: MonadReader (CombinedEnv o d t r era) m => TransferLogicEnv -> ReaderT (CombinedEnv o d Identity r era) m a -> m a +withTransfer dir action = do + asks (addTransferEnv dir) + >>= runReaderT action + +withTransferFor :: MonadReader (CombinedEnv o d t r era) m => C.Hash C.PaymentKey -> ReaderT (CombinedEnv o d Identity r era) m a -> m a +withTransferFor = withTransfer . mkTransferLogicEnv + +withTransferFromOperator :: MonadReader (CombinedEnv Identity d t r era) m => ReaderT (CombinedEnv Identity d Identity r era) m a -> m a +withTransferFromOperator action = do + env <- ask + let opPkh = fst . bteOperator . operatorEnv $ env + runReaderT action (addTransferEnv (mkTransferLogicEnv opPkh) env) + +{-| Add a 'DirectoryEnv' for the 'C.TxIn' in to the environment and run the +action with the modified environment +-} +withEnv :: forall era m a. ReaderT (CombinedEnv Proxy Proxy Proxy Proxy era) m a -> m a +withEnv = flip runReaderT empty + +{-| Add a 'RuntimeEnv' to the environment +-} +addRuntimeEnv :: RuntimeEnv -> CombinedEnv o d t r era -> CombinedEnv o d t Identity era +addRuntimeEnv env e = + e{ceRuntime = Identity env } + +withRuntime :: MonadReader (CombinedEnv o d t r era) m => RuntimeEnv -> ReaderT (CombinedEnv o d t Identity era) m a -> m a +withRuntime runtime action = + asks (addRuntimeEnv runtime) + >>= runReaderT action + +{-| Add an 'OperatorEnv' to the environment +-} +addOperatorEnv :: OperatorEnv era -> CombinedEnv o d t r era2 -> CombinedEnv Identity d t r era +addOperatorEnv op e = + e{ceOperator = Identity op } + +withOperator :: MonadReader (CombinedEnv o d t r era1) m => OperatorEnv era -> ReaderT (CombinedEnv Identity d t r era) m a -> m a +withOperator op action = asks (addOperatorEnv op) >>= runReaderT action diff --git a/src/lib/Wst/Offchain/Query.hs b/src/lib/Wst/Offchain/Query.hs new file mode 100644 index 0000000..1ea3b87 --- /dev/null +++ b/src/lib/Wst/Offchain/Query.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-| Look up outputs at script addresses +-} +module Wst.Offchain.Query( + -- * Queries + blacklistNodes, + registryNodes, + globalParamsNode, + programmableLogicOutputs, + userProgrammableOutputs, + + -- * UTxO with datum + UTxODat(..), + fromOutput +) where + +import Cardano.Api qualified as C +import Control.Lens qualified as L +import Control.Monad ((>=>)) +import Control.Monad.Except (MonadError, throwError) +import Control.Monad.Reader (MonadReader, asks) +import Convex.CardanoApi.Lenses qualified as L +import Convex.Class (MonadBlockchain (queryNetworkId), MonadUtxoQuery, + utxosByPaymentCredential) +import Convex.PlutusLedger.V1 (transCredential, unTransStakeCredential) +import Convex.Scripts (fromHashableScriptData) +import Convex.Utxos (UtxoSet, toApiUtxo) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map qualified as Map +import Data.Maybe (listToMaybe, mapMaybe) +import GHC.Generics (Generic) +import PlutusTx qualified +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import SmartTokens.Types.PTokenDirectory (BlacklistNode, DirectorySetNode (..)) +import Wst.AppError (AppError (GlobalParamsNodeNotFound)) +import Wst.Offchain.Env (DirectoryEnv (dsDirectorySpendingScript, dsProgrammableLogicBaseScript), + HasDirectoryEnv (directoryEnv), + HasTransferLogicEnv (transferLogicEnv), + TransferLogicEnv (tleBlacklistSpendingScript)) +import Wst.Offchain.Scripts (protocolParamsSpendingScript) + +-- TODO: We should probably filter the UTxOs to check that they have the correct NFTs + +{-| Unspent transaction output with 'TxIn', 'TxOut' and an inline datum +-} +data UTxODat era a = + UTxODat + { uIn :: C.TxIn + , uOut :: C.TxOut C.CtxUTxO era + , uDatum :: a + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +{-| Find all UTxOs that make up the registry +-} +registryNodes :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era DirectorySetNode] +registryNodes = + asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsDirectorySpendingScript . directoryEnv) + >>= fmap (extractUTxO @era) . utxosByPaymentCredential + +{-| Find all UTxOs that make up the blacklist +-} +blacklistNodes :: forall era env m. (MonadReader env m, HasTransferLogicEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era BlacklistNode] +blacklistNodes = + asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . tleBlacklistSpendingScript . transferLogicEnv) + >>= fmap (extractUTxO @era) . utxosByPaymentCredential + +userProgrammableOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadBlockchain era m) => C.PaymentCredential -> m [UTxODat era ()] +userProgrammableOutputs userCred = do + nid <- queryNetworkId + baseCred <- asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript . directoryEnv) + + userStakeCred <- either (error . ("Could not unTrans credential: " <>) . show) pure $ unTransStakeCredential $ transCredential userCred + let expectedAddress = C.makeShelleyAddressInEra C.shelleyBasedEra nid baseCred (C.StakeAddressByValue userStakeCred) + isUserUtxo UTxODat{uOut=(C.TxOut addr _ _ _)} = addr == expectedAddress + + filter isUserUtxo <$> programmableLogicOutputs + +{-| Find the UTxO with the global params +-} +globalParamsNode :: forall era m. (MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) +globalParamsNode = do + let cred = C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 $ protocolParamsSpendingScript + utxosByPaymentCredential cred + >>= maybe (throwError GlobalParamsNodeNotFound) pure . listToMaybe . extractUTxO @era + +{-| Outputs that are locked by the programmable logic base script. +-} +programmableLogicOutputs :: forall era env m. (MonadReader env m, HasDirectoryEnv env, MonadUtxoQuery m, C.IsBabbageBasedEra era) => m [UTxODat era ()] +programmableLogicOutputs = do + asks (C.PaymentCredentialByScript . C.hashScript . C.PlutusScript C.PlutusScriptV3 . dsProgrammableLogicBaseScript . directoryEnv) + >>= fmap (extractUtxoNoDatum @era) . utxosByPaymentCredential + +fromOutputNoDatum :: forall era. (C.IsBabbageBasedEra era) => C.TxIn -> C.TxOut C.CtxUTxO era -> Maybe (UTxODat era ()) +fromOutputNoDatum uIn uOut@(L.preview (L._TxOut . L._3 . L._TxOutDatumInline) >=> fromHashableScriptData -> Just ()) = Just UTxODat{uIn, uOut, uDatum = ()} +fromOutputNoDatum uIn uOut = Just $ UTxODat{uIn, uOut, uDatum = ()} + +extractUtxoNoDatum :: forall era b. (C.IsBabbageBasedEra era) => UtxoSet C.CtxUTxO b -> [UTxODat era ()] +extractUtxoNoDatum = mapMaybe (uncurry fromOutputNoDatum) . Map.toList . C.unUTxO . toApiUtxo @era + +fromOutput :: forall era a. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => C.TxIn -> C.TxOut C.CtxUTxO era -> Maybe (UTxODat era a) +fromOutput uIn uOut@(L.preview (L._TxOut . L._3 . L._TxOutDatumInline) >=> fromHashableScriptData -> Just uDatum) = Just UTxODat{uIn, uOut, uDatum} +fromOutput _ _ = Nothing + +extractUTxO :: forall era a b. (PlutusTx.FromData a, C.IsBabbageBasedEra era) => UtxoSet C.CtxUTxO b -> [UTxODat era a] +extractUTxO = mapMaybe (uncurry fromOutput) . Map.toList . C.unUTxO . toApiUtxo @era diff --git a/src/lib/Wst/Offchain/Scripts.hs b/src/lib/Wst/Offchain/Scripts.hs new file mode 100644 index 0000000..a5e71a1 --- /dev/null +++ b/src/lib/Wst/Offchain/Scripts.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Wst.Offchain.Scripts ( + protocolParamsMintingScript, + protocolParamsSpendingScript, + directoryNodeMintingScript, + directoryNodeSpendingScript, + programmableLogicMintingScript, + programmableLogicBaseScript, + programmableLogicGlobalScript, + + -- Transfer logic + permissionedTransferScript, + freezeTransferScript, + blacklistMintingScript, + blacklistSpendingScript, + + -- * Always suceeds + alwaysSucceedsScript, + + -- Utils + scriptPolicyIdV3 + ) + where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Convex.PlutusLedger.V1 (transCredential, transPolicyId, transPubKeyHash, + transStakeCredential) +import Convex.PlutusLedger.V3 (transTxOutRef) +import Plutarch (ClosedTerm, Config (..), LogLevel (..), TracingMode (..), (#)) +import Plutarch.Builtin (pdata, pforgetData) +import Plutarch.ByteString (PByteString) +import Plutarch.Lift (pconstant) +import Plutarch.Script (serialiseScript) +import SmartTokens.Contracts.AlwaysYields (palwaysSucceed) +import SmartTokens.Contracts.ExampleTransferLogic (mkFreezeAndSeizeTransfer, + mkPermissionedTransfer) +import SmartTokens.Contracts.Issuance (mkProgrammableLogicMinting) +import SmartTokens.Contracts.ProgrammableLogicBase (mkProgrammableLogicBase, + mkProgrammableLogicGlobal) +import SmartTokens.Contracts.ProtocolParams (alwaysFailScript, + mkPermissionedMinting, + mkProtocolParametersMinting) +import SmartTokens.Core.Scripts (tryCompile) +import SmartTokens.LinkedList.MintDirectory (mkDirectoryNodeMP) +import SmartTokens.LinkedList.SpendDirectory (pmkDirectorySpending) + +tracingConfig :: Config +tracingConfig = Tracing LogInfo DoTracingAndBinds + +prodConfig :: Config +prodConfig = NoTracing + +-- Protocol params + +-- | The minting script for the protocol parameters NFT, takes initial TxIn for +-- one shot mint +protocolParamsMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 +protocolParamsMintingScript txIn = + let script = tryCompile prodConfig $ mkProtocolParametersMinting # pdata (pconstant $ transTxOutRef txIn) + in C.PlutusScriptSerialised $ serialiseScript script + +-- | The spending script for the protocol parameters NFT parameterized by "" +-- nonce +protocolParamsSpendingScript :: C.PlutusScript C.PlutusScriptV3 +protocolParamsSpendingScript = + let script = tryCompile prodConfig $ alwaysFailScript # pforgetData (pdata (pconstant "" :: ClosedTerm PByteString)) + in C.PlutusScriptSerialised $ serialiseScript script + +-- | The minting script for the directory node tokens, takes initial TxIn for +-- symbol uniqueness across instances +directoryNodeMintingScript :: C.TxIn -> C.PlutusScript C.PlutusScriptV3 +directoryNodeMintingScript txIn = + let script = tryCompile prodConfig $ mkDirectoryNodeMP # pdata (pconstant $ transTxOutRef txIn) + in C.PlutusScriptSerialised $ serialiseScript script + +-- | The spending script for the directory node tokens, parameterized by the +-- policy id of the protocol parameters NFT. +directoryNodeSpendingScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +directoryNodeSpendingScript paramsPolId = + let script = tryCompile prodConfig $ pmkDirectorySpending # pdata (pconstant $ transPolicyId paramsPolId) + in C.PlutusScriptSerialised $ serialiseScript script + +-- TODO: can we change the signature to just take the param policy id? +programmableLogicMintingScript :: C.PaymentCredential -> C.StakeCredential -> C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +programmableLogicMintingScript progLogicBaseSpndingCred mintingCred nodePolId = + let script = tryCompile prodConfig + $ mkProgrammableLogicMinting + # pdata (pconstant $ transCredential progLogicBaseSpndingCred) + # pdata (pconstant $ transPolicyId nodePolId) + # pdata (pconstant $ transStakeCredential mintingCred) + in C.PlutusScriptSerialised $ serialiseScript script + +programmableLogicBaseScript :: C.StakeCredential -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the stake cred of the global script +programmableLogicBaseScript globalCred = + let script = tryCompile prodConfig $ mkProgrammableLogicBase # pdata (pconstant $ transStakeCredential globalCred) + in C.PlutusScriptSerialised $ serialiseScript script + +programmableLogicGlobalScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 -- Parameterized by the CS holding protocol params datum +programmableLogicGlobalScript paramsPolId = + let script = tryCompile prodConfig $ mkProgrammableLogicGlobal # pdata (pconstant $ transPolicyId paramsPolId) + in C.PlutusScriptSerialised $ serialiseScript script + +permissionedTransferScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +permissionedTransferScript cred = + let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) + in C.PlutusScriptSerialised $ serialiseScript script + +freezeTransferScript :: C.PolicyId -> C.PlutusScript C.PlutusScriptV3 +freezeTransferScript blacklistPolicyId = + let script = tryCompile prodConfig $ mkFreezeAndSeizeTransfer # pdata (pconstant $ transPolicyId blacklistPolicyId) + in C.PlutusScriptSerialised $ serialiseScript script + +blacklistMintingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +blacklistMintingScript cred = + let script = tryCompile prodConfig $ mkPermissionedMinting # pdata (pconstant $ transPubKeyHash cred) + in C.PlutusScriptSerialised $ serialiseScript script + +blacklistSpendingScript :: C.Hash C.PaymentKey -> C.PlutusScript C.PlutusScriptV3 +blacklistSpendingScript cred = + let script = tryCompile prodConfig $ mkPermissionedTransfer # pdata (pconstant $ transPubKeyHash cred) + in C.PlutusScriptSerialised $ serialiseScript script + +{-| 'C.PlutusScript C.PlutusScriptV3' that always succeeds. Can be used for minting, withdrawal, spending, etc. +-} +alwaysSucceedsScript :: C.PlutusScript C.PlutusScriptV3 +alwaysSucceedsScript = + C.PlutusScriptSerialised $ serialiseScript $ tryCompile prodConfig palwaysSucceed + +-- Utilities +scriptPolicyIdV3 :: C.PlutusScript C.PlutusScriptV3 -> C.PolicyId +scriptPolicyIdV3 = C.scriptPolicyId . C.PlutusScript C.PlutusScriptV3 diff --git a/src/lib/Wst/Onchain.hs b/src/lib/Wst/Onchain.hs index b3c4193..e5fd3d5 100644 --- a/src/lib/Wst/Onchain.hs +++ b/src/lib/Wst/Onchain.hs @@ -2,4 +2,4 @@ -} module Wst.Onchain() where --- add plutarch scripts \ No newline at end of file +-- add plutarch scripts diff --git a/src/lib/Wst/Server.hs b/src/lib/Wst/Server.hs index db6a399..1612da0 100644 --- a/src/lib/Wst/Server.hs +++ b/src/lib/Wst/Server.hs @@ -1,3 +1,66 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + {-| servant server for stablecoin POC -} -module Wst.Server() where \ No newline at end of file +module Wst.Server(runServer) where + +import Cardano.Api qualified as C +import Control.Monad.Except (MonadError) +import Control.Monad.Reader (MonadReader, asks) +import Convex.Class (MonadBlockchain, MonadUtxoQuery) +import Data.Data (Proxy (..)) +import Network.Wai.Handler.Warp qualified as Warp +import Servant (Server, ServerT) +import Servant.API (NoContent (..), (:<|>) (..)) +import Servant.Server (hoistServer, serve) +import Wst.App (WstApp, runWstAppServant) +import Wst.AppError (AppError) +import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs) +import Wst.Offchain.Endpoints.Deployment qualified as Endpoints +import Wst.Offchain.Env qualified as C +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query qualified as Query +import Wst.Server.Types (APIInEra, BuildTxAPI, IssueProgrammableTokenArgs (..), + QueryAPI, TextEnvelopeJSON (..)) + +runServer :: (Env.HasRuntimeEnv env, Env.HasDirectoryEnv env) => env -> IO () +runServer env = do + let app = serve (Proxy @APIInEra) (server env) + port = 8081 + Warp.run port app + +server :: forall env. (Env.HasRuntimeEnv env, C.HasDirectoryEnv env) => env -> Server APIInEra +server env = hoistServer (Proxy @APIInEra) (runWstAppServant env) $ + healthcheck + :<|> queryApi @env @C.ConwayEra + :<|> txApi @env + +healthcheck :: Applicative m => m NoContent +healthcheck = pure NoContent + +queryApi :: forall env era. C.IsBabbageBasedEra era => ServerT (QueryAPI era) (WstApp env era) +queryApi = Query.globalParamsNode + +txApi :: forall env. (C.HasDirectoryEnv env) => ServerT (BuildTxAPI C.ConwayEra) (WstApp env C.ConwayEra) +txApi = + issueProgrammableTokenEndpoint @C.ConwayEra @env + +issueProgrammableTokenEndpoint :: forall era env m. + ( MonadReader env m + , Env.HasDirectoryEnv env + , MonadBlockchain era m + , MonadError (AppError era) m + , C.IsBabbageBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV3 era + , MonadUtxoQuery m + ) + => IssueProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era)) +issueProgrammableTokenEndpoint IssueProgrammableTokenArgs{itaAssetName, itaQuantity, itaOperatorAddress} = do + operatorEnv <- Env.loadOperatorEnvFromAddress itaOperatorAddress + dirEnv <- asks Env.directoryEnv + + -- FIXME: Replace alwaysSucceedsArgs with blacklist monetary policy as soon as it is finished + let tokenArgs = alwaysSucceedsArgs + Env.withEnv $ Env.withOperator operatorEnv $ Env.withDirectory dirEnv $ do + TextEnvelopeJSON <$> Endpoints.issueProgrammableTokenTx tokenArgs itaAssetName itaQuantity diff --git a/src/lib/Wst/Server/Endpoints.hs b/src/lib/Wst/Server/Endpoints.hs new file mode 100644 index 0000000..8949dfd --- /dev/null +++ b/src/lib/Wst/Server/Endpoints.hs @@ -0,0 +1,31 @@ + +{- | This module contains the endpoints of the server. +-} +module Wst.Server.Endpoints ( + healthcheck, + -- * Query endpoints + queryGlobalParams, + + -- * Build tx endpoints + issueProgrammableTokens +) where + +import Cardano.Api qualified as C +import Control.Monad.Except (MonadError) +import Convex.Class (MonadUtxoQuery) +import Servant (Handler) +import Servant.API (NoContent (..)) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.AppError (AppError) +import Wst.Offchain.Query (UTxODat) +import Wst.Offchain.Query qualified as Query +import Wst.Server.Types (IssueProgrammableTokenArgs, TextEnvelopeJSON) + +healthcheck :: Handler NoContent +healthcheck = pure NoContent + +queryGlobalParams :: forall era m. (MonadUtxoQuery m, C.IsBabbageBasedEra era, MonadError (AppError era) m) => m (UTxODat era ProgrammableLogicGlobalParams) +queryGlobalParams = Query.globalParamsNode + +issueProgrammableTokens :: forall era m. IssueProgrammableTokenArgs -> m (TextEnvelopeJSON (C.Tx era)) +issueProgrammableTokens = undefined diff --git a/src/lib/Wst/Server/Types.hs b/src/lib/Wst/Server/Types.hs new file mode 100644 index 0000000..3aa2e5b --- /dev/null +++ b/src/lib/Wst/Server/Types.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE TypeOperators #-} + + +{- | This module contains the relevant types for the server. + -} +module Wst.Server.Types ( + API, + APIInEra, + QueryAPI, + BuildTxAPI, + IssueProgrammableTokenArgs(..), + TextEnvelopeJSON(..), +) where + +import Cardano.Api (AssetName, Quantity) +import Cardano.Api qualified as C +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic) +import Servant.API (Description, Get, JSON, NoContent, Post, ReqBody, type (:>), + (:<|>) (..)) +import SmartTokens.Types.ProtocolParams (ProgrammableLogicGlobalParams) +import Wst.Offchain.Query (UTxODat (..)) + +type APIInEra = API C.ConwayEra + +newtype TextEnvelopeJSON a = TextEnvelopeJSON{ unTextEnvelopeJSON :: a } + +instance C.HasTextEnvelope a => ToJSON (TextEnvelopeJSON a) where + toJSON = toJSON . C.serialiseToTextEnvelope Nothing . unTextEnvelopeJSON + +instance C.HasTextEnvelope a => FromJSON (TextEnvelopeJSON a) where + parseJSON val = parseJSON val >>= either (fail . show) (pure . TextEnvelopeJSON) . C.deserialiseFromTextEnvelope (C.proxyToAsType Proxy) + +type API era = + "healthcheck" :> Description "Is the server alive?" :> Get '[JSON] NoContent + :<|> "query" :> QueryAPI era + :<|> "tx" :> BuildTxAPI era + +type QueryAPI era = + "global-params" :> Description "The UTxO with the global parameters" :> Get '[JSON] (UTxODat era ProgrammableLogicGlobalParams) + +{-| Arguments for the programmable-token endpoint. The asset name can be something like "USDW" for the regulated stablecoin. +-} +data IssueProgrammableTokenArgs = + IssueProgrammableTokenArgs + { itaOperatorAddress :: C.Address C.ShelleyAddr + , itaAssetName :: AssetName + , itaQuantity :: Quantity + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +type BuildTxAPI era = + "programmable-token" :> "issue" :> Description "Create some programamble tokens" :> ReqBody '[JSON] IssueProgrammableTokenArgs :> Post '[JSON] (TextEnvelopeJSON (C.Tx era)) diff --git a/src/test/Spec.hs b/src/test/Spec.hs new file mode 100644 index 0000000..1ee44aa --- /dev/null +++ b/src/test/Spec.hs @@ -0,0 +1,8 @@ +module Main (main) where + +import Test.Tasty (defaultMain) + +import Wst.Test.UnitTest qualified as Unit + +main :: IO () +main = defaultMain Unit.tests diff --git a/src/test/Wst/Test/Env.hs b/src/test/Wst/Test/Env.hs new file mode 100644 index 0000000..edc2141 --- /dev/null +++ b/src/test/Wst/Test/Env.hs @@ -0,0 +1,60 @@ +{-| Running tests that use the 'BuildTxEv' +-} +module Wst.Test.Env( + admin, + asAdmin, + asWallet, + user, +) where + +import Cardano.Api.Shelley qualified as C +import Control.Monad.Reader (MonadReader, ReaderT) +import Convex.Class (MonadUtxoQuery) +import Convex.Wallet qualified as Wallet +import Convex.Wallet.MockWallet (w1) +import Convex.Wallet.Operator (Operator (..), PaymentExtendedKey (..), Signing) +import Convex.Wallet.Operator qualified as Operator +import Data.Functor.Identity (Identity) +import Wst.Offchain.Env qualified as Env + +{-| Key used for actions of the stableoin issuer / operator. +-} +admin :: Operator Signing +admin = + Operator + { oPaymentKey = PESigning (Wallet.getWallet w1) + , oStakeKey = Nothing + } + +user :: Wallet.Wallet -> Operator Signing +user w = + Operator + { oPaymentKey = PESigning (Wallet.getWallet w) + , oStakeKey = Nothing + } + +{-| Run an action using the "admin" key. Deploying the system, minting stablecoins, etc. +-} +asAdmin :: forall era o d t r m a. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader (Env.CombinedEnv o d t r era) m + ) + => ReaderT (Env.CombinedEnv Identity d t r era) m a -> m a +asAdmin action = do + env <- Env.loadOperatorEnv + (C.verificationKeyHash . Operator.verificationKey . oPaymentKey $ admin) + (maybe C.NoStakeAddress (C.StakeAddressByValue . C.StakeCredentialByKey . C.verificationKeyHash) $ Operator.oStakeKey admin) + Env.withOperator env action + +asWallet :: forall era o d t r m a. + ( MonadUtxoQuery m + , C.IsBabbageBasedEra era + , MonadReader (Env.CombinedEnv o d t r era) m + ) + => Wallet.Wallet -> ReaderT (Env.CombinedEnv Identity d t r era) m a -> m a +asWallet w action = do + env <- Env.loadOperatorEnv + (C.verificationKeyHash . Operator.verificationKey . oPaymentKey $ user w) + (maybe C.NoStakeAddress (C.StakeAddressByValue . C.StakeCredentialByKey . C.verificationKeyHash) $ Operator.oStakeKey $ user w) + Env.withOperator env action diff --git a/src/test/Wst/Test/UnitTest.hs b/src/test/Wst/Test/UnitTest.hs new file mode 100644 index 0000000..42c33d0 --- /dev/null +++ b/src/test/Wst/Test/UnitTest.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE OverloadedStrings #-} +module Wst.Test.UnitTest( + tests +) where + +import Cardano.Api qualified as C +import Cardano.Api.Shelley qualified as C +import Cardano.Ledger.Core qualified as Ledger +import Cardano.Ledger.Shelley.TxCert qualified as TxCert +import Control.Lens ((^.)) +import Control.Monad (void) +import Control.Monad.Reader (asks) +import Control.Monad.Reader.Class (MonadReader) +import Convex.BuildTx (MonadBuildTx, addCertificate) +import Convex.BuildTx qualified as BuildTx +import Convex.Class (MonadBlockchain (queryProtocolParameters, sendTx), + MonadMockchain, MonadUtxoQuery) +import Convex.CoinSelection (ChangeOutputPosition (TrailingChange)) +import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) +import Convex.MockChain.Utils (mockchainFails, mockchainSucceeds) +import Convex.Utils (failOnError) +import Convex.Wallet.MockWallet qualified as Wallet +import Convex.Wallet.Operator (signTxOperator) +import Data.List (isPrefixOf) +import GHC.Exception (SomeException, throw) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, testCase) +import Wst.Offchain.BuildTx.DirectorySet (InsertNodeArgs (..)) +import Wst.Offchain.BuildTx.ProgrammableLogic (alwaysSucceedsArgs) +import Wst.Offchain.Endpoints.Deployment qualified as Endpoints +import Wst.Offchain.Env qualified as Env +import Wst.Offchain.Query qualified as Query +import Wst.Offchain.Scripts qualified as Scripts +import Wst.Test.Env (admin, asAdmin, asWallet, user) + +tests :: TestTree +tests = testGroup "unit tests" + [ testCase "deploy directory and global params" (mockchainSucceeds deployDirectorySet) + , testCase "insert directory node" (mockchainSucceeds insertDirectoryNode) + , testGroup "issue programmable tokens" + [ testCase "always succeeds validator" (mockchainSucceeds issueAlwaysSucceedsValidator) + , testCase "smart token issuance" (mockchainSucceeds issueSmartTokensScenario) + , testCase "smart token transfer" (mockchainSucceeds transferSmartTokens) + , testCase "blacklist credential" (mockchainSucceeds (void blacklistCredential)) + , testCase "blacklisted transfer" (mockchainFails blacklistTransfer assertBlacklistedAddressException) + , testCase "seize user output" (mockchainSucceeds seizeUserOutput) + ] + ] + +deployDirectorySet :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m C.TxIn +deployDirectorySet = failOnError $ Env.withEnv $ asAdmin @C.ConwayEra $ do + (tx, txI) <- Endpoints.deployTx + void $ sendTx $ signTxOperator admin tx + Env.withDirectoryFor txI $ do + Query.registryNodes @C.ConwayEra + >>= void . expectSingleton "registry output" + void $ Query.globalParamsNode @C.ConwayEra + pure txI + +insertDirectoryNode :: (MonadUtxoQuery m, MonadBlockchain C.ConwayEra m, MonadFail m) => m () +insertDirectoryNode = failOnError $ Env.withEnv $ do + txI <- deployDirectorySet + asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do + Endpoints.insertNodeTx dummyNodeArgs >>= void . sendTx . signTxOperator admin + Query.registryNodes @C.ConwayEra + >>= void . expectN 2 "registry outputs" + +{-| Issue some tokens with the "always succeeds" validator +-} +issueAlwaysSucceedsValidator :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +issueAlwaysSucceedsValidator = failOnError $ Env.withEnv $ do + + -- Register the stake validator + -- Oddly, the tests passes even if we don't do this. + -- But I'll leave it in because it seems right. + registerAlwaysSucceedsStakingCert + + txI <- deployDirectorySet + asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ do + Endpoints.issueProgrammableTokenTx alwaysSucceedsArgs "dummy asset" 100 + >>= void . sendTx . signTxOperator admin + Query.registryNodes @C.ConwayEra + >>= void . expectN 2 "registry outputs" + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 1 "programmable logic outputs" + +issueSmartTokensScenario :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.AssetId +issueSmartTokensScenario = deployDirectorySet >>= issueTransferLogicProgrammableToken + +{-| Issue some tokens with the smart stabelcoin transfer logic validator +-} +issueTransferLogicProgrammableToken :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => C.TxIn -> m C.AssetId +issueTransferLogicProgrammableToken txI = failOnError $ Env.withEnv $ do + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + -- register programmable global stake script + void $ registerTransferScripts opPkh + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + + (balTx, aid) <- Endpoints.issueSmartTokensTx "dummy asset" 100 (C.PaymentCredentialByKey opPkh) + void $ sendTx $ signTxOperator admin balTx + + Query.registryNodes @C.ConwayEra + >>= void . expectN 2 " registry outputs" + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 1 "programmable logic outputs" + pure aid + +{-| Issue some tokens with the smart stabelcoin transfer logic validator +-} +transferSmartTokens :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +transferSmartTokens = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) + txI <- deployDirectorySet + + asAdmin @C.ConwayEra $ Env.withTransferFromOperator $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + Query.blacklistNodes @C.ConwayEra + >>= void . expectSingleton "blacklist output" + + aid <- issueTransferLogicProgrammableToken txI + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txI $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + + Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 80 (C.PaymentCredentialByKey userPkh) + >>= void . sendTx . signTxOperator admin + + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 2 "programmable logic outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey userPkh) + >>= void . expectN 1 "user programmable outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey opPkh) + >>= void . expectN 1 "user programmable outputs" + +blacklistCredential :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m C.PaymentCredential +blacklistCredential = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) + let paymentCred = C.PaymentCredentialByKey userPkh + + txIn <- deployDirectorySet + + asAdmin @C.ConwayEra $ Env.withTransferFromOperator $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + Query.blacklistNodes @C.ConwayEra + >>= void . expectSingleton "blacklist output" + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + Endpoints.blacklistCredentialTx paymentCred + >>= void . sendTx . signTxOperator admin + + Query.blacklistNodes @C.ConwayEra + >>= void . expectN 2 "blacklist output" + + pure paymentCred + +blacklistTransfer :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +blacklistTransfer = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) + let userPaymentCred = C.PaymentCredentialByKey userPkh + + txIn <- deployDirectorySet + aid <- issueTransferLogicProgrammableToken txIn + + asAdmin @C.ConwayEra $ Env.withTransferFromOperator $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + + opPkh <- asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 50 (C.PaymentCredentialByKey userPkh) + >>= void . sendTx . signTxOperator admin + pure opPkh + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + Endpoints.blacklistCredentialTx userPaymentCred + >>= void . sendTx . signTxOperator admin + + asWallet Wallet.w2 $ Env.withDirectoryFor txIn $ Env.withTransferFor opPkh $ do + Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey userPkh) aid 30 (C.PaymentCredentialByKey opPkh) + >>= void . sendTx . signTxOperator (user Wallet.w2) + +seizeUserOutput :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +seizeUserOutput = failOnError $ Env.withEnv $ do + userPkh <- asWallet Wallet.w2 $ asks (fst . Env.bteOperator . Env.operatorEnv) + let userPaymentCred = C.PaymentCredentialByKey userPkh + + txIn <- deployDirectorySet + aid <- issueTransferLogicProgrammableToken txIn + + asAdmin @C.ConwayEra $ Env.withTransferFromOperator $ do + Endpoints.deployBlacklistTx + >>= void . sendTx . signTxOperator admin + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + Endpoints.transferSmartTokensTx (C.PaymentCredentialByKey opPkh) aid 50 (C.PaymentCredentialByKey userPkh) + >>= void . sendTx . signTxOperator admin + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 2 "programmable logic outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey userPkh) + >>= void . expectN 1 "user programmable outputs" + + asAdmin @C.ConwayEra $ Env.withDirectoryFor txIn $ Env.withTransferFromOperator $ do + opPkh <- asks (fst . Env.bteOperator . Env.operatorEnv) + Endpoints.seizeCredentialAssetsTx userPaymentCred + >>= void . sendTx . signTxOperator admin + Query.programmableLogicOutputs @C.ConwayEra + >>= void . expectN 3 "programmable logic outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey userPkh) + >>= void . expectN 1 "user programmable outputs" + Query.userProgrammableOutputs (C.PaymentCredentialByKey opPkh) + >>= void . expectN 2 "user programmable outputs" + + +dummyNodeArgs :: InsertNodeArgs +dummyNodeArgs = + InsertNodeArgs + { inaNewKey = "e165610232235bbbbeff5b998b23e165610232235bbbbeff5b998b23" + , inaTransferLogic = C.StakeCredentialByScript "e165610232235bbbbeff5b998b23e165610232235bbbbeff5b998b23" + , inaIssuerLogic = C.StakeCredentialByScript "e165610232235bbbbeff5b998b23e165610232235bbbbeff5b998b23" + } + +{-| Register the 'alwaysSucceedsScript' stake validator +-} +registerAlwaysSucceedsStakingCert :: (MonadUtxoQuery m, MonadFail m, MonadMockchain C.ConwayEra m) => m () +registerAlwaysSucceedsStakingCert = failOnError $ do + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + let script = C.PlutusScript C.plutusScriptVersion Scripts.alwaysSucceedsScript + hsh = C.hashScript script + cred = C.StakeCredentialByScript hsh + txBody <- BuildTx.execBuildTxT $ do + BuildTx.addStakeScriptWitness cred Scripts.alwaysSucceedsScript () + BuildTx.addConwayStakeCredentialRegistrationCertificate cred (pp ^. Ledger.ppKeyDepositL) + void (tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []) + +registerTransferScripts :: (MonadFail m, MonadReader env m, Env.HasDirectoryEnv env, Env.HasTransferLogicEnv env, MonadMockchain C.ConwayEra m) => C.Hash C.PaymentKey -> m C.TxId +registerTransferScripts pkh = failOnError $ do + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + transferMintingScript <- asks (Env.tleMintingScript . Env.transferLogicEnv) + transferSpendingScript <- asks (Env.tleTransferScript . Env.transferLogicEnv) + transferGlobalScript <- asks (Env.dsProgrammableLogicGlobalScript . Env.directoryEnv) + let + hshMinting = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferMintingScript + credMinting = C.StakeCredentialByScript hshMinting + + hshSpending = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferSpendingScript + credSpending = C.StakeCredentialByScript hshSpending + + hshGlobal = C.hashScript $ C.PlutusScript C.plutusScriptVersion transferGlobalScript + credGlobal = C.StakeCredentialByScript hshGlobal + + txBody <- BuildTx.execBuildTxT $ do + BuildTx.addStakeScriptWitness credMinting transferMintingScript () + BuildTx.addConwayStakeCredentialRegistrationCertificate credMinting (pp ^. Ledger.ppKeyDepositL) + + addStakeCredentialCertificate credSpending + addStakeCredentialCertificate credGlobal + + BuildTx.addRequiredSignature pkh + + x <- tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] + pure $ C.getTxId $ C.getTxBody x + +{-| Add a 'C.StakeCredential' as a certificate to the transaction +-} +addStakeCredentialCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m () +addStakeCredentialCertificate stk = + C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ + addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk + +expectSingleton :: MonadFail m => String -> [a] -> m a +expectSingleton msg = \case + [a] -> pure a + ls -> fail $ "Expected a single " ++ msg ++ " but found " ++ show (length ls) + +expectN :: MonadFail m => Int -> String -> [a] -> m () +expectN n msg lst + | length lst == n = pure () + | otherwise = fail $ "Expected " ++ show n ++ " " ++ msg ++ " but found " ++ show (length lst) + +_expectLeft :: (MonadFail m, Show b) => String -> Either a b -> m () +_expectLeft msg = \case + Left _ -> pure () + (Right r) -> fail $ "Expected " ++ msg ++ " but found Right " ++ show r + +-- TODO: Need to make this nicer +{-| Make sure that the exception is a failure due to blacklisted address +-} +assertBlacklistedAddressException :: SomeException -> Assertion +assertBlacklistedAddressException ex + | "user error (TransferBlacklistedCredential (PubKeyCredential" `isPrefixOf` show ex = pure () + | otherwise = throw ex diff --git a/src/wst-poc.cabal b/src/wst-poc.cabal index e9fbcac..3a7057c 100644 --- a/src/wst-poc.cabal +++ b/src/wst-poc.cabal @@ -6,8 +6,8 @@ license: Apache-2.0 license-files: LICENSE maintainer: j-mueller@users.noreply.github.com author: Djed team @ IOG -homepage: https://github.com/input-output-hk/wst-poc -bug-reports: https://github.com/input-output-hk/wst-poc +homepage: https://github.com/input-output-hk/wsc-poc +bug-reports: https://github.com/input-output-hk/wsc-poc description: Please see the README on GitHub at @@ -17,72 +17,167 @@ description: extra-source-files: CHANGELOG.md common lang - default-language: Haskell2010 - default-extensions: ExplicitForAll ScopedTypeVariables MultiParamTypeClasses - DeriveGeneric StandaloneDeriving DeriveLift FlexibleContexts - GeneralizedNewtypeDeriving DeriveFunctor DeriveFoldable - DeriveTraversable ImportQualifiedPost NumericUnderscores - LambdaCase DerivingStrategies KindSignatures TypeApplications - DataKinds TypeOperators GADTs ViewPatterns TypeFamilies - DeriveAnyClass DerivingVia RankNTypes - ghc-options: -Wall -Wnoncanonical-monad-instances -Wunused-packages - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wredundant-constraints -Widentities + default-language: Haskell2010 + default-extensions: + DataKinds + DeriveAnyClass + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + ExplicitForAll + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + KindSignatures + LambdaCase + MultiParamTypeClasses + NumericUnderscores + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + + ghc-options: + -Wall -Wnoncanonical-monad-instances -Wunused-packages + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities library - import: lang + import: lang exposed-modules: + Profile + SmartTokens.CodeLens + SmartTokens.Contracts.AlwaysYields + SmartTokens.Contracts.ExampleTransferLogic SmartTokens.Contracts.Issuance SmartTokens.Contracts.ProgrammableLogicBase - SmartTokens.Contracts.ExampleTransferLogic SmartTokens.Contracts.ProtocolParams + SmartTokens.Core.Scripts + SmartTokens.LinkedList.Common + SmartTokens.LinkedList.MintDirectory + SmartTokens.LinkedList.SpendDirectory SmartTokens.Types.Constants SmartTokens.Types.ProtocolParams SmartTokens.Types.PTokenDirectory - SmartTokens.LinkedList.MintDirectory - SmartTokens.LinkedList.SpendDirectory - SmartTokens.LinkedList.Common Types.Constants + Wst.App + Wst.AppError Wst.Cli + Wst.Cli.Command + Wst.Client Wst.Offchain + Wst.Offchain.BuildTx.Blacklist + Wst.Offchain.BuildTx.DirectorySet + Wst.Offchain.BuildTx.LinkedList + Wst.Offchain.BuildTx.ProgrammableLogic + Wst.Offchain.BuildTx.ProtocolParams + Wst.Offchain.BuildTx.TransferLogic + Wst.Offchain.Endpoints.Deployment + Wst.Offchain.Env + Wst.Offchain.Query + Wst.Offchain.Scripts Wst.Onchain Wst.Server - Profile - - -- Compile + Wst.Server.Endpoints + Wst.Server.Types + hs-source-dirs: lib build-depends: - , base - , plutarch-onchain-lib + , aeson + , base >=4.14 && <4.20 + , base16-bytestring + , Blammo + , blockfrost-api + , blockfrost-client-core + , bytestring + , cardano-api + , cardano-ledger-api + , cardano-ledger-shelley + , containers + , convex-base + , convex-blockfrost + , convex-coin-selection + , convex-mockchain + , convex-node-client + , convex-optics + , convex-wallet , generics-sop + , lens + , mtl + , optparse-applicative , plutarch , plutarch-ledger-api + , plutarch-onchain-lib , plutus-core , plutus-ledger-api , plutus-tx + , servant + , servant-client + , servant-client-core + , servant-server , text + , warp - hs-source-dirs: lib -executable wst-poc - import: lang - main-is: Main.hs - hs-source-dirs: exe/wst-poc + hs-source-dirs: lib + +executable wst-poc-cli + import: lang + main-is: Main.hs + hs-source-dirs: exe/wst-poc-cli build-depends: - base, - wst-poc + , base + , wst-poc executable export-smart-tokens import: lang main-is: Main.hs - build-depends: - , wst-poc + build-depends: + , aeson , aeson-pretty , base - , cardano-binary - , aeson , base16-bytestring , bytestring - , text + , cardano-binary , plutarch , plutus-ledger-api + , text + , wst-poc + hs-source-dirs: exe/export-smart-tokens + +test-suite wst-poc-test + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: test + ghc-options: + -fobject-code -fno-ignore-interface-pragmas + -fno-omit-interface-pragmas -fno-specialise -Wno-unused-packages + + main-is: Spec.hs + other-modules: + Wst.Test.Env + Wst.Test.UnitTest + + build-depends: + , base >=4.14.0 + , cardano-api + , cardano-ledger-core + , cardano-ledger-shelley + , convex-base + , convex-coin-selection + , convex-mockchain + , convex-wallet + , lens + , mtl + , plutus-ledger-api + , tasty + , tasty-hunit + , wst-poc