From b1eed7b35803eb91acf9139ccd4057f83267b6df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Sat, 22 May 2021 01:37:05 +0200 Subject: [PATCH 01/11] started with week 8 --- code/week08/.devcontainer/devcontainer.json | 23 ++ code/week08/.gitignore | 6 + code/week08/LICENSE | 201 +++++++++++++++++ code/week08/cabal.project | 145 +++++++++++++ code/week08/hie.yaml | 4 + .../plutus-pioneer-program-week08.cabal | 29 +++ code/week08/src/Week08/StateMachine.hs | 204 ++++++++++++++++++ 7 files changed, 612 insertions(+) create mode 100644 code/week08/.devcontainer/devcontainer.json create mode 100644 code/week08/.gitignore create mode 100644 code/week08/LICENSE create mode 100644 code/week08/cabal.project create mode 100644 code/week08/hie.yaml create mode 100644 code/week08/plutus-pioneer-program-week08.cabal create mode 100644 code/week08/src/Week08/StateMachine.hs diff --git a/code/week08/.devcontainer/devcontainer.json b/code/week08/.devcontainer/devcontainer.json new file mode 100644 index 0000000..51f7dce --- /dev/null +++ b/code/week08/.devcontainer/devcontainer.json @@ -0,0 +1,23 @@ +{ + "name": "Plutus Starter Project", + "image": "plutus-devcontainer:latest", + + "remoteUser": "plutus", + + "mounts": [ + // This shares cabal's remote repository state with the host. We don't mount the whole of '.cabal', because + // 1. '.cabal/config' contains absolute paths that will only make sense on the host, and + // 2. '.cabal/store' is not necessarily portable to different version of cabal etc. + "source=${localEnv:HOME}/.cabal/packages,target=/home/plutus/.cabal/packages,type=bind,consistency=cached", + ], + + "settings": { + // Note: don't change from bash so it runs .bashrc + "terminal.integrated.shell.linux": "/bin/bash" + }, + + // IDs of extensions inside container + "extensions": [ + "haskell.haskell" + ], +} diff --git a/code/week08/.gitignore b/code/week08/.gitignore new file mode 100644 index 0000000..2bbd0a6 --- /dev/null +++ b/code/week08/.gitignore @@ -0,0 +1,6 @@ +dist-newstyle/ +oracle.cid +W2.cid +W3.cid +W4.cid +W5.cid diff --git a/code/week08/LICENSE b/code/week08/LICENSE new file mode 100644 index 0000000..261eeb9 --- /dev/null +++ b/code/week08/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/code/week08/cabal.project b/code/week08/cabal.project new file mode 100644 index 0000000..17ccfce --- /dev/null +++ b/code/week08/cabal.project @@ -0,0 +1,145 @@ +index-state: 2021-04-13T00:00:00Z + +packages: ./. + +-- You never, ever, want this. +write-ghc-environment-files: never + +-- Always build tests and benchmarks. +tests: true +benchmarks: true + +source-repository-package + type: git + location: https://github.com/input-output-hk/plutus.git + subdir: + freer-extras + playground-common + plutus-core + plutus-contract + plutus-ledger + plutus-ledger-api + plutus-pab + plutus-tx + plutus-tx-plugin + plutus-use-cases + prettyprinter-configurable + quickcheck-dynamic + tag: b1894eb48d3d9c9b7acd83dd39f27b6b01d4a09e + +-- The following sections are copied from the 'plutus' repository cabal.project at the revision +-- given above. +-- This is necessary because the 'plutus' libraries depend on a number of other libraries which are +-- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to +-- re-update this section from the template when you do an upgrade. + +-- This is also needed so evenful-sql-common will build with a +-- newer version of persistent. See stack.yaml for the mirrored +-- configuration. +package eventful-sql-common + ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances + +allow-newer: + -- Has a commit to allow newer aeson, not on Hackage yet + monoidal-containers:aeson + -- Pins to an old version of Template Haskell, unclear if/when it will be updated + , size-based:template-haskell + + -- The following two dependencies are needed by plutus. + , eventful-sql-common:persistent + , eventful-sql-common:persistent-template + +constraints: + -- aws-lambda-haskell-runtime-wai doesn't compile with newer versions + aws-lambda-haskell-runtime <= 3.0.3 + -- big breaking change here, inline-r doens't have an upper bound + , singletons < 3.0 + -- breaks eventful even more than it already was + , persistent-template < 2.12 + +-- See the note on nix/pkgs/default.nix:agdaPackages for why this is here. +-- (NOTE this will change to ieee754 in newer versions of nixpkgs). +extra-packages: ieee, filemanip + + +-- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) +source-repository-package + type: git + location: https://github.com/shmish111/purescript-bridge.git + tag: 6a92d7853ea514be8b70bab5e72077bf5a510596 + +source-repository-package + type: git + location: https://github.com/shmish111/servant-purescript.git + tag: a76104490499aa72d40c2790d10e9383e0dbde63 + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-crypto.git + tag: f73079303f663e028288f9f4a9e08bcca39a923e + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-base + tag: 4251c0bb6e4f443f00231d28f5f70d42876da055 + subdir: + binary + binary/test + slotting + cardano-crypto-class + cardano-crypto-praos + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-prelude + tag: ee4e7b547a991876e6b05ba542f4e62909f4a571 + subdir: + cardano-prelude + cardano-prelude-test + +source-repository-package + type: git + location: https://github.com/input-output-hk/ouroboros-network + tag: 6cb9052bde39472a0555d19ade8a42da63d3e904 + subdir: + typed-protocols + typed-protocols-examples + ouroboros-network + ouroboros-network-testing + ouroboros-network-framework + io-sim + io-sim-classes + network-mux + Win32-network + +source-repository-package + type: git + location: https://github.com/input-output-hk/iohk-monitoring-framework + tag: a89c38ed5825ba17ca79fddb85651007753d699d + subdir: + iohk-monitoring + tracer-transformers + contra-tracer + plugins/backend-ekg + +source-repository-package + type: git + location: https://github.com/input-output-hk/cardano-ledger-specs + tag: 097890495cbb0e8b62106bcd090a5721c3f4b36f + subdir: + byron/chain/executable-spec + byron/crypto + byron/crypto/test + byron/ledger/executable-spec + byron/ledger/impl + byron/ledger/impl/test + semantics/executable-spec + semantics/small-steps-test + shelley/chain-and-ledger/dependencies/non-integer + shelley/chain-and-ledger/executable-spec + shelley-ma/impl + +source-repository-package + type: git + location: https://github.com/input-output-hk/goblins + tag: cde90a2b27f79187ca8310b6549331e59595e7ba diff --git a/code/week08/hie.yaml b/code/week08/hie.yaml new file mode 100644 index 0000000..d60a69e --- /dev/null +++ b/code/week08/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "./src" + component: "lib:plutus-pioneer-program-week08" diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal new file mode 100644 index 0000000..7a8748e --- /dev/null +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -0,0 +1,29 @@ +Cabal-Version: 2.4 +Name: plutus-pioneer-program-week08 +Version: 0.1.0.0 +Author: Lars Bruenjes +Maintainer: brunjlar@gmail.com +Build-Type: Simple +Copyright: © 2021 Lars Bruenjes +License: Apache-2.0 +License-files: LICENSE + +library + hs-source-dirs: src + exposed-modules: Week08.StateMachine + build-depends: aeson + , base ^>=4.14.1.0 + , containers + , data-default + , freer-extras + , playground-common + , plutus-contract + , plutus-ledger + , plutus-ledger-api + , plutus-tx-plugin + , plutus-tx + , plutus-use-cases + , prettyprinter + , text + default-language: Haskell2010 + ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise diff --git a/code/week08/src/Week08/StateMachine.hs b/code/week08/src/Week08/StateMachine.hs new file mode 100644 index 0000000..6676f2d --- /dev/null +++ b/code/week08/src/Week08/StateMachine.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.StateMachine where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import Plutus.Contract.Test +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import Ledger.Typed.Tx +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Playground.Contract (ToSchema) +import Prelude (Semigroup (..)) +import qualified Prelude + +data TokenSale = TokenSale + { tsSeller :: !PubKeyHash + , tsToken :: !AssetClass + , tsNFT :: !AssetClass + } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) + +PlutusTx.makeLift ''TokenSale + +data TSRedeemer = + SetPrice Integer + | AddTokens Integer + | BuyTokens Integer + | Withdraw Integer Integer + deriving Show + +PlutusTx.unstableMakeIsData ''TSRedeemer + +{-# INLINABLE lovelaces #-} +lovelaces :: Value -> Integer +lovelaces = Ada.getLovelace . Ada.fromValue + +{-# INLINABLE transition #-} +transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) +transition ts s r = case (stateValue s, stateData s, r) of + (v, _, SetPrice p) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p v + ) + (v, p, AddTokens n) -> Just ( mempty + , State p $ v <> assetClassValue (tsToken ts) n + ) + (v, p, BuyTokens n) -> Just ( mempty + , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) + ) + (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) + ) + +{-# INLINABLE tsStateMachine #-} +tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer +tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) + +{-# INLINABLE mkTSValidator #-} +mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool +mkTSValidator = mkValidator . tsStateMachine + +type TS = StateMachine Integer TSRedeemer + +tsInst :: TokenSale -> Scripts.ScriptInstance TS +tsInst ts = Scripts.validator @TS + ($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @Integer @TSRedeemer + +tsValidator :: TokenSale -> Validator +tsValidator = Scripts.validatorScript . tsInst + +tsAddress :: TokenSale -> Ledger.Address +tsAddress = scriptAddress . tsValidator + +tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer +tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) + +{- + + + + +data FirstParams = FirstParams + { fpSecond :: !PubKeyHash + , fpStake :: !Integer + , fpPlayDeadline :: !Slot + , fpRevealDeadline :: !Slot + , fpNonce :: !ByteString + , fpCurrency :: !CurrencySymbol + , fpTokenName :: !TokenName + , fpChoice :: !GameChoice + } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) + +mapError' :: Contract w s SMContractError a -> Contract w s Text a +mapError' = mapError $ pack . show + +firstGame :: forall w s. HasBlockchainActions s => FirstParams -> Contract w s Text () +firstGame fp = do + pkh <- pubKeyHash <$> Contract.ownPubKey + let game = Game + { gFirst = pkh + , gSecond = fpSecond fp + , gStake = fpStake fp + , gPlayDeadline = fpPlayDeadline fp + , gRevealDeadline = fpRevealDeadline fp + , gToken = AssetClass (fpCurrency fp, fpTokenName fp) + } + client = gameClient game + v = lovelaceValueOf (fpStake fp) + c = fpChoice fp + bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne + void $ mapError' $ runInitialise client (GameDatum bs Nothing) v + logInfo @String $ "made first move: " ++ show (fpChoice fp) + + void $ awaitSlot $ 1 + fpPlayDeadline fp + + m <- mapError' $ getOnChainState client + case m of + Nothing -> throwError "game output not found" + Just ((o, _), _) -> case tyTxOutData o of + + GameDatum _ Nothing -> do + logInfo @String "second player did not play" + void $ mapError' $ runStep client ClaimFirst + logInfo @String "first player reclaimed stake" + + GameDatum _ (Just c') | c' == c -> do + logInfo @String "second player played and lost" + void $ mapError' $ runStep client $ Reveal $ fpNonce fp + logInfo @String "first player revealed and won" + + _ -> logInfo @String "second player played and won" + +data SecondParams = SecondParams + { spFirst :: !PubKeyHash + , spStake :: !Integer + , spPlayDeadline :: !Slot + , spRevealDeadline :: !Slot + , spCurrency :: !CurrencySymbol + , spTokenName :: !TokenName + , spChoice :: !GameChoice + } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) + +secondGame :: forall w s. HasBlockchainActions s => SecondParams -> Contract w s Text () +secondGame sp = do + pkh <- pubKeyHash <$> Contract.ownPubKey + let game = Game + { gFirst = spFirst sp + , gSecond = pkh + , gStake = spStake sp + , gPlayDeadline = spPlayDeadline sp + , gRevealDeadline = spRevealDeadline sp + , gToken = AssetClass (spCurrency sp, spTokenName sp) + } + client = gameClient game + m <- mapError' $ getOnChainState client + case m of + Nothing -> logInfo @String "no running game found" + Just ((o, _), _) -> case tyTxOutData o of + GameDatum _ Nothing -> do + logInfo @String "running game found" + void $ mapError' $ runStep client $ Play $ spChoice sp + logInfo @String $ "made second move: " ++ show (spChoice sp) + + void $ awaitSlot $ 1 + spRevealDeadline sp + + m' <- mapError' $ getOnChainState client + case m' of + Nothing -> logInfo @String "first player won" + Just _ -> do + logInfo @String "first player didn't reveal" + void $ mapError' $ runStep client ClaimSecond + logInfo @String "second player won" + + _ -> throwError "unexpected datum" + +type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams + +endpoints :: Contract () GameSchema Text () +endpoints = (first `select` second) >> endpoints + where + first = endpoint @"first" >>= firstGame + second = endpoint @"second" >>= secondGame +-} From 0e622f33c66fd28b1213f4515c90b844f470bab7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Sun, 23 May 2021 16:37:21 +0200 Subject: [PATCH 02/11] complete version of the token sales contract --- .../plutus-pioneer-program-week08.cabal | 4 +- code/week08/src/Week08/StateMachine.hs | 204 ------------------ code/week08/src/Week08/TestTokenSale.hs | 35 +++ code/week08/src/Week08/TokenSale.hs | 160 ++++++++++++++ code/week08/src/Week08/TraceTokenSale.hs | 94 ++++++++ 5 files changed, 292 insertions(+), 205 deletions(-) delete mode 100644 code/week08/src/Week08/StateMachine.hs create mode 100644 code/week08/src/Week08/TestTokenSale.hs create mode 100644 code/week08/src/Week08/TokenSale.hs create mode 100644 code/week08/src/Week08/TraceTokenSale.hs diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal index 7a8748e..fbd4ca5 100644 --- a/code/week08/plutus-pioneer-program-week08.cabal +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -10,7 +10,9 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week08.StateMachine + exposed-modules: Week08.TokenSale + , Week08.TestTokenSale + , Week08.TraceTokenSale build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week08/src/Week08/StateMachine.hs b/code/week08/src/Week08/StateMachine.hs deleted file mode 100644 index 6676f2d..0000000 --- a/code/week08/src/Week08/StateMachine.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Week08.StateMachine where - -import Control.Monad hiding (fmap) -import Data.Aeson (FromJSON, ToJSON) -import Data.Text (Text, pack) -import GHC.Generics (Generic) -import Plutus.Contract as Contract hiding (when) -import Plutus.Contract.StateMachine -import Plutus.Contract.Test -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), check, unless) -import Ledger hiding (singleton) -import Ledger.Ada as Ada -import Ledger.Constraints as Constraints -import Ledger.Typed.Tx -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Value -import Playground.Contract (ToSchema) -import Prelude (Semigroup (..)) -import qualified Prelude - -data TokenSale = TokenSale - { tsSeller :: !PubKeyHash - , tsToken :: !AssetClass - , tsNFT :: !AssetClass - } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) - -PlutusTx.makeLift ''TokenSale - -data TSRedeemer = - SetPrice Integer - | AddTokens Integer - | BuyTokens Integer - | Withdraw Integer Integer - deriving Show - -PlutusTx.unstableMakeIsData ''TSRedeemer - -{-# INLINABLE lovelaces #-} -lovelaces :: Value -> Integer -lovelaces = Ada.getLovelace . Ada.fromValue - -{-# INLINABLE transition #-} -transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) -transition ts s r = case (stateValue s, stateData s, r) of - (v, _, SetPrice p) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p v - ) - (v, p, AddTokens n) -> Just ( mempty - , State p $ v <> assetClassValue (tsToken ts) n - ) - (v, p, BuyTokens n) -> Just ( mempty - , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) - ) - (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p $ v <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) - ) - -{-# INLINABLE tsStateMachine #-} -tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer -tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) - -{-# INLINABLE mkTSValidator #-} -mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool -mkTSValidator = mkValidator . tsStateMachine - -type TS = StateMachine Integer TSRedeemer - -tsInst :: TokenSale -> Scripts.ScriptInstance TS -tsInst ts = Scripts.validator @TS - ($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @Integer @TSRedeemer - -tsValidator :: TokenSale -> Validator -tsValidator = Scripts.validatorScript . tsInst - -tsAddress :: TokenSale -> Ledger.Address -tsAddress = scriptAddress . tsValidator - -tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer -tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) - -{- - - - - -data FirstParams = FirstParams - { fpSecond :: !PubKeyHash - , fpStake :: !Integer - , fpPlayDeadline :: !Slot - , fpRevealDeadline :: !Slot - , fpNonce :: !ByteString - , fpCurrency :: !CurrencySymbol - , fpTokenName :: !TokenName - , fpChoice :: !GameChoice - } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) - -mapError' :: Contract w s SMContractError a -> Contract w s Text a -mapError' = mapError $ pack . show - -firstGame :: forall w s. HasBlockchainActions s => FirstParams -> Contract w s Text () -firstGame fp = do - pkh <- pubKeyHash <$> Contract.ownPubKey - let game = Game - { gFirst = pkh - , gSecond = fpSecond fp - , gStake = fpStake fp - , gPlayDeadline = fpPlayDeadline fp - , gRevealDeadline = fpRevealDeadline fp - , gToken = AssetClass (fpCurrency fp, fpTokenName fp) - } - client = gameClient game - v = lovelaceValueOf (fpStake fp) - c = fpChoice fp - bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne - void $ mapError' $ runInitialise client (GameDatum bs Nothing) v - logInfo @String $ "made first move: " ++ show (fpChoice fp) - - void $ awaitSlot $ 1 + fpPlayDeadline fp - - m <- mapError' $ getOnChainState client - case m of - Nothing -> throwError "game output not found" - Just ((o, _), _) -> case tyTxOutData o of - - GameDatum _ Nothing -> do - logInfo @String "second player did not play" - void $ mapError' $ runStep client ClaimFirst - logInfo @String "first player reclaimed stake" - - GameDatum _ (Just c') | c' == c -> do - logInfo @String "second player played and lost" - void $ mapError' $ runStep client $ Reveal $ fpNonce fp - logInfo @String "first player revealed and won" - - _ -> logInfo @String "second player played and won" - -data SecondParams = SecondParams - { spFirst :: !PubKeyHash - , spStake :: !Integer - , spPlayDeadline :: !Slot - , spRevealDeadline :: !Slot - , spCurrency :: !CurrencySymbol - , spTokenName :: !TokenName - , spChoice :: !GameChoice - } deriving (Show, Generic, FromJSON, ToJSON, ToSchema) - -secondGame :: forall w s. HasBlockchainActions s => SecondParams -> Contract w s Text () -secondGame sp = do - pkh <- pubKeyHash <$> Contract.ownPubKey - let game = Game - { gFirst = spFirst sp - , gSecond = pkh - , gStake = spStake sp - , gPlayDeadline = spPlayDeadline sp - , gRevealDeadline = spRevealDeadline sp - , gToken = AssetClass (spCurrency sp, spTokenName sp) - } - client = gameClient game - m <- mapError' $ getOnChainState client - case m of - Nothing -> logInfo @String "no running game found" - Just ((o, _), _) -> case tyTxOutData o of - GameDatum _ Nothing -> do - logInfo @String "running game found" - void $ mapError' $ runStep client $ Play $ spChoice sp - logInfo @String $ "made second move: " ++ show (spChoice sp) - - void $ awaitSlot $ 1 + spRevealDeadline sp - - m' <- mapError' $ getOnChainState client - case m' of - Nothing -> logInfo @String "first player won" - Just _ -> do - logInfo @String "first player didn't reveal" - void $ mapError' $ runStep client ClaimSecond - logInfo @String "second player won" - - _ -> throwError "unexpected datum" - -type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams - -endpoints :: Contract () GameSchema Text () -endpoints = (first `select` second) >> endpoints - where - first = endpoint @"first" >>= firstGame - second = endpoint @"second" >>= secondGame --} diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs new file mode 100644 index 0000000..57fc75e --- /dev/null +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TestTokenSale where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import Plutus.Contract.Test +import qualified Plutus.Contracts.Currency as C +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Prelude (Semigroup (..)) +import qualified Prelude + +import Week08.TokenSale diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs new file mode 100644 index 0000000..e7c34ca --- /dev/null +++ b/code/week08/src/Week08/TokenSale.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TokenSale + ( TokenSale (..) + , TSStartSchema + , TSUseSchema + , startTS' + , useTS + ) where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid (Last (..)) +import Data.Text (Text, pack) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Contract.StateMachine +import qualified Plutus.Contracts.Currency as C +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), check, unless) +import Ledger hiding (singleton) +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Prelude (Semigroup (..)) +import qualified Prelude + +data TokenSale = TokenSale + { tsSeller :: !PubKeyHash + , tsToken :: !AssetClass + , tsNFT :: !AssetClass + } deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord) + +PlutusTx.makeLift ''TokenSale + +data TSRedeemer = + SetPrice Integer + | AddTokens Integer + | BuyTokens Integer + | Withdraw Integer Integer + deriving Show + +PlutusTx.unstableMakeIsData ''TSRedeemer + +{-# INLINABLE lovelaces #-} +lovelaces :: Value -> Integer +lovelaces = Ada.getLovelace . Ada.fromValue + +{-# INLINABLE transition #-} +transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) +transition ts s r = case (stateValue s, stateData s, r) of + (v, _, SetPrice p) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p (v <> nft (negate 1)) + ) + (v, p, AddTokens n) -> Just ( mempty + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n + ) + (v, p, BuyTokens n) -> Just ( mempty + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) + ) + (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) + ) + where + nft :: Integer -> Value + nft = assetClassValue (tsNFT ts) + +{-# INLINABLE tsStateMachine #-} +tsStateMachine :: TokenSale -> StateMachine Integer TSRedeemer +tsStateMachine ts = mkStateMachine (Just $ tsNFT ts) (transition ts) (const False) + +{-# INLINABLE mkTSValidator #-} +mkTSValidator :: TokenSale -> Integer -> TSRedeemer -> ScriptContext -> Bool +mkTSValidator = mkValidator . tsStateMachine + +type TS = StateMachine Integer TSRedeemer + +tsInst :: TokenSale -> Scripts.ScriptInstance TS +tsInst ts = Scripts.validator @TS + ($$(PlutusTx.compile [|| mkTSValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode ts) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @Integer @TSRedeemer + +tsValidator :: TokenSale -> Validator +tsValidator = Scripts.validatorScript . tsInst + +tsAddress :: TokenSale -> Ledger.Address +tsAddress = scriptAddress . tsValidator + +tsClient :: TokenSale -> StateMachineClient Integer TSRedeemer +tsClient ts = mkStateMachineClient $ StateMachineInstance (tsStateMachine ts) (tsInst ts) + +mapErrorC :: Contract w s C.CurrencyError a -> Contract w s Text a +mapErrorC = mapError $ pack . show + +mapErrorSM :: Contract w s SMContractError a -> Contract w s Text a +mapErrorSM = mapError $ pack . show + + +nftName :: TokenName +nftName = "NFT" + +startTS :: HasBlockchainActions s => AssetClass -> Contract (Last TokenSale) s Text () +startTS token = do + pkh <- pubKeyHash <$> Contract.ownPubKey + osc <- mapErrorC $ C.forgeContract pkh [(nftName, 1)] + let ts = TokenSale + { tsSeller = pkh + , tsToken = token + , tsNFT = AssetClass (C.currencySymbol osc, nftName) + } + client = tsClient ts + void $ mapErrorSM $ runInitialise client 0 mempty + tell $ Last $ Just ts + logInfo $ "started token sale " ++ show ts + +setPrice :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () +setPrice ts p = void $ mapErrorSM $ runStep (tsClient ts) $ SetPrice p + +addTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () +addTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ AddTokens n + +buyTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () +buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n + +withdraw :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text () +withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l + +type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) +type TSUseSchema = BlockchainActions + .\/ Endpoint "set price" Integer + .\/ Endpoint "add tokens" Integer + .\/ Endpoint "buy tokens" Integer + .\/ Endpoint "withdraw" (Integer, Integer) + +startTS' :: Contract (Last TokenSale) TSStartSchema Text () +startTS' = start >> startTS' + where + start = endpoint @"start" >>= startTS . AssetClass + +useTS :: TokenSale -> Contract () TSUseSchema Text () +useTS ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useTS ts + where + setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts + addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts + buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts + withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/src/Week08/TraceTokenSale.hs new file mode 100644 index 0000000..6616282 --- /dev/null +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week08.TraceTokenSale where + +import Control.Monad hiding (fmap) +import Control.Monad.Freer.Extras as Extras +import Data.Default (Default (..)) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Ledger +import Ledger.Value +import Ledger.Ada as Ada +import Plutus.Trace.Emulator as Emulator +import PlutusTx.Prelude +import Wallet.Emulator.Wallet + +import Week08.TokenSale + +test :: IO () +test = runEmulatorTraceIO' def emCfg myTrace + where + emCfg :: EmulatorConfig + emCfg = EmulatorConfig $ Left $ Map.fromList + [ (Wallet w, v) + | w <- [1 .. 3] + ] + + v :: Value + v = Ada.lovelaceValueOf 1000_000_000 + <> assetClassValue token1 1000 + <> assetClassValue token2 1000 + +currency1, currency2 :: CurrencySymbol +currency1 = "aa" +currency2 = "bb" + +name1, name2 :: TokenName +name1 = "A" +name2 = "B" + +token1, token2 :: AssetClass +token1 = AssetClass (currency1, name1) +token2 = AssetClass (currency2, name2) + +myTrace :: EmulatorTrace () +myTrace = do + h <- activateContractWallet (Wallet 1) startTS' + callEndpoint @"start" h (currency1, name1) + void $ Emulator.waitNSlots 5 + Last m <- observableState h + case m of + Nothing -> Extras.logError @String "error starting token sale" + Just ts -> do + Extras.logInfo $ "started token sale " ++ show ts + + h1 <- activateContractWallet (Wallet 1) $ useTS ts + h2 <- activateContractWallet (Wallet 2) $ useTS ts + h3 <- activateContractWallet (Wallet 3) $ useTS ts + + callEndpoint @"set price" h1 1_000_000 + void $ Emulator.waitNSlots 5 + + callEndpoint @"set price" h2 2_000_000 + void $ Emulator.waitNSlots 5 + + callEndpoint @"add tokens" h1 100 + void $ Emulator.waitNSlots 5 + + callEndpoint @"add tokens" h2 10 + void $ Emulator.waitNSlots 5 + + callEndpoint @"buy tokens" h2 20 + void $ Emulator.waitNSlots 5 + + callEndpoint @"buy tokens" h3 5 + void $ Emulator.waitNSlots 5 + + callEndpoint @"withdraw" h1 (40, 10_000_000) + void $ Emulator.waitNSlots 5 + + callEndpoint @"withdraw" h2 (40, 10_000_000) + void $ Emulator.waitNSlots 5 From b4e6f8886a8a8227dbc70278f1a94ec61541b24d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Mon, 24 May 2021 22:21:05 +0200 Subject: [PATCH 03/11] first working version --- .../plutus-pioneer-program-week08.cabal | 2 + code/week08/src/Week08/TestTokenSale.hs | 189 ++++++++++++++++-- code/week08/src/Week08/TokenSale.hs | 28 ++- 3 files changed, 194 insertions(+), 25 deletions(-) diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal index fbd4ca5..28c7d22 100644 --- a/code/week08/plutus-pioneer-program-week08.cabal +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -18,6 +18,7 @@ library , containers , data-default , freer-extras + , lens , playground-common , plutus-contract , plutus-ledger @@ -26,6 +27,7 @@ library , plutus-tx , plutus-use-cases , prettyprinter + , QuickCheck , text default-language: Haskell2010 ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs index 57fc75e..3e2f73a 100644 --- a/code/week08/src/Week08/TestTokenSale.hs +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -2,10 +2,13 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -13,23 +16,175 @@ module Week08.TestTokenSale where -import Control.Monad hiding (fmap) -import Data.Aeson (FromJSON, ToJSON) -import Data.Monoid (Last (..)) -import Data.Text (Text, pack) -import GHC.Generics (Generic) -import Plutus.Contract as Contract hiding (when) -import Plutus.Contract.StateMachine +import Control.Lens hiding (elements) +import Control.Monad (void, when) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isJust, isNothing) +import Data.Monoid (Last (..)) +import Data.Text (Text) import Plutus.Contract.Test -import qualified Plutus.Contracts.Currency as C -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), check, unless) -import Ledger hiding (singleton) -import Ledger.Ada as Ada -import Ledger.Constraints as Constraints -import qualified Ledger.Typed.Scripts as Scripts +import Plutus.Contract.Test.ContractModel +import Plutus.Trace.Emulator +import Ledger hiding (singleton) +import Ledger.Ada as Ada import Ledger.Value -import Prelude (Semigroup (..)) -import qualified Prelude +import Test.QuickCheck import Week08.TokenSale + +data TSState = TSState + { _tssPrice :: !Integer + , _tssLovelace :: !Integer + , _tssToken :: !Integer + } deriving Show + +makeLenses ''TSState + +newtype TSModel = TSModel {_tsModel :: Map Wallet TSState} + deriving Show + +makeLenses ''TSModel + +instance ContractModel TSModel where + + data Action TSModel = Start Wallet | TSAction Wallet Wallet TSRedeemer + deriving (Show, Eq) + + data ContractInstanceKey TSModel w s e where + StartKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSStartSchema' Text + UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text + + arbitraryAction _ = oneof $ + (Start <$> genSeller) : + [ (\v w p -> TSAction v w $ SetPrice p) <$> genSeller <*> genUser <*> arbitrary ] ++ + [ (\v w n -> TSAction v w $ AddTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++ + [ (\v w n -> TSAction v w $ BuyTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++ + [ (\v w n l -> TSAction v w $ Withdraw n l) <$> genSeller <*> genUser <*> arbitrary <*> arbitrary ] + + initialState = TSModel Map.empty + + nextState (Start w) = do + withdraw w $ nfts Map.! w + (tsModel . at w) $= Just (TSState 0 0 0) + wait 1 + + nextState (TSAction v w (SetPrice p)) = when (v == w) $ do + (tsModel . ix v . tssPrice) $= p + wait 1 + + nextState (TSAction v w (AddTokens n)) = do + started <- hasStarted v -- has the token sale started? + when (n > 0 && started) $ do + bc <- askModelState $ view $ balanceChange w + let token = tokens Map.! v + when (assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give? + withdraw w $ assetClassValue token n + (tsModel . ix v . tssToken) $~ (+ n) + wait 1 + + nextState (TSAction v w (BuyTokens n)) = do + when (n > 0) $ do + m <- getTSState v + case m of + Just t + | t ^. tssToken >= n -> do + let p = t ^. tssPrice + l = p * n + withdraw w $ lovelaceValueOf l + deposit w $ assetClassValue (tokens Map.! v) n + (tsModel . ix v . tssLovelace) $~ (+ l) + (tsModel . ix v . tssToken) $~ (+ (- n)) + _ -> return () + wait 1 + + nextState (TSAction v w (Withdraw n l)) = when (v == w) $ do + withdraw w $ lovelaceValueOf l <> assetClassValue (tokens Map.! v) n + (tsModel . ix v . tssLovelace) $~ (+ (- l)) + (tsModel . ix v . tssToken) $~ (+ (- n)) + wait 1 + + perform h _ cmd = case cmd of + (Start w) -> callEndpoint @"start" (h $ StartKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1 + (TSAction v w (SetPrice p)) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1 + (TSAction v w (AddTokens n)) -> callEndpoint @"add tokens" (h $ UseKey v w) n >> delay 1 + (TSAction v w (BuyTokens n)) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 + (TSAction v w (Withdraw n l)) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1 + + precondition s (Start w) = isNothing $ getTSState' s w + precondition _ _ = True + +deriving instance Eq (ContractInstanceKey TSModel w s e) +deriving instance Show (ContractInstanceKey TSModel w s e) + +getTSState' :: ModelState TSModel -> Wallet -> Maybe TSState +getTSState' s v = s ^. contractState . tsModel . at v + +getTSState :: Wallet -> Spec TSModel (Maybe TSState) +getTSState v = do + s <- getModelState + return $ getTSState' s v + +hasStarted :: Wallet -> Spec TSModel Bool +hasStarted v = isJust <$> getTSState v + +w1, w2, w3, w4 :: Wallet +w1 = Wallet 1 +w2 = Wallet 2 +w3 = Wallet 3 +w4 = Wallet 4 + +tokenCurrency :: CurrencySymbol +tokenCurrency = "ff" + +tokenNames :: Map Wallet TokenName +tokenNames = Map.fromList [(w1, "A"), (w2, "B")] + +tokens :: Map Wallet AssetClass +tokens = (\tn -> AssetClass (tokenCurrency, tn)) <$> tokenNames + +wallets :: [Wallet] +wallets = [w1, w2, w3, w4] + +css :: Map Wallet CurrencySymbol +css = Map.fromList [(w1, "01"), (w2, "02")] + +nfts :: Map Wallet Value +nfts = (\cs -> assetClassValue (AssetClass (cs, nftName)) 1) <$> css + +tss :: Map Wallet TokenSale +tss = Map.fromList + [ (w, TokenSale (pubKeyHash $ walletPubKey w) (tokens Map.! w) $ AssetClass (css Map.! w, nftName)) + | w <- [w1, w2] + ] + +delay :: Int -> EmulatorTrace () +delay = void . waitNSlots . fromIntegral + +instanceSpec :: [ContractInstanceSpec TSModel] +instanceSpec = + [ContractInstanceSpec (StartKey w) w $ startTS'' | w <- [w1, w2]] ++ + [ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]] + +genSeller, genUser :: Gen Wallet +genSeller = elements [w1, w2] +genUser = elements [w3, w4] + +prop_TS :: Actions TSModel -> Property +prop_TS = propRunActionsWithOptions + (defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d)) + instanceSpec + (const $ pure True) + where + d :: InitialDistribution + d = Map.fromList $ [ ( w + , lovelaceValueOf 1000_000_000 <> + (nfts Map.! w) <> + mconcat [assetClassValue t 1000 | t <- Map.elems tokens]) + | w <- [w1, w2] + ] ++ + [(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]] + + +test :: IO () +test = quickCheck prop_TS diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index e7c34ca..4ec5fef 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -13,9 +13,13 @@ module Week08.TokenSale ( TokenSale (..) + , TSRedeemer (..) + , nftName , TSStartSchema + , TSStartSchema' , TSUseSchema , startTS' + , startTS'' , useTS ) where @@ -50,7 +54,7 @@ data TSRedeemer = | AddTokens Integer | BuyTokens Integer | Withdraw Integer Integer - deriving Show + deriving (Show, Prelude.Eq) PlutusTx.unstableMakeIsData ''TSRedeemer @@ -113,14 +117,16 @@ mapErrorSM = mapError $ pack . show nftName :: TokenName nftName = "NFT" -startTS :: HasBlockchainActions s => AssetClass -> Contract (Last TokenSale) s Text () -startTS token = do +startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text () +startTS mcs token = do pkh <- pubKeyHash <$> Contract.ownPubKey - osc <- mapErrorC $ C.forgeContract pkh [(nftName, 1)] + cs <- case mcs of + Nothing -> C.currencySymbol <$> mapErrorC (C.forgeContract pkh [(nftName, 1)]) + Just cs' -> return cs' let ts = TokenSale { tsSeller = pkh , tsToken = token - , tsNFT = AssetClass (C.currencySymbol osc, nftName) + , tsNFT = AssetClass (cs, nftName) } client = tsClient ts void $ mapErrorSM $ runInitialise client 0 mempty @@ -139,8 +145,9 @@ buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n withdraw :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text () withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l -type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) -type TSUseSchema = BlockchainActions +type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) +type TSStartSchema' = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName) +type TSUseSchema = BlockchainActions .\/ Endpoint "set price" Integer .\/ Endpoint "add tokens" Integer .\/ Endpoint "buy tokens" Integer @@ -149,7 +156,12 @@ type TSUseSchema = BlockchainActions startTS' :: Contract (Last TokenSale) TSStartSchema Text () startTS' = start >> startTS' where - start = endpoint @"start" >>= startTS . AssetClass + start = endpoint @"start" >>= startTS Nothing . AssetClass + +startTS'' :: Contract (Last TokenSale) TSStartSchema' Text () +startTS'' = start >> startTS'' + where + start = endpoint @"start" >>= \(cs1, cs2, tn) -> startTS (Just cs1) $ AssetClass (cs2, tn) useTS :: TokenSale -> Contract () TSUseSchema Text () useTS ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useTS ts From d3af622a7117e4f40c9beb9036aaee5bdaec0724 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 25 May 2021 00:13:56 +0200 Subject: [PATCH 04/11] changed endpoints --- code/week08/src/Week08/TestTokenSale.hs | 85 ++++++++++++++++-------- code/week08/src/Week08/TokenSale.hs | 84 ++++++++++++++--------- code/week08/src/Week08/TraceTokenSale.hs | 16 +---- 3 files changed, 110 insertions(+), 75 deletions(-) diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs index 3e2f73a..036cc05 100644 --- a/code/week08/src/Week08/TestTokenSale.hs +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -31,7 +31,7 @@ import Ledger.Ada as Ada import Ledger.Value import Test.QuickCheck -import Week08.TokenSale +import Week08.TokenSale (TokenSale (..), TSOperateSchema', TSUseSchema, useTS, operateTS'', nftName) data TSState = TSState { _tssPrice :: !Integer @@ -48,19 +48,24 @@ makeLenses ''TSModel instance ContractModel TSModel where - data Action TSModel = Start Wallet | TSAction Wallet Wallet TSRedeemer + data Action TSModel = + Start Wallet + | SetPrice Wallet Integer + | AddTokens Wallet Integer + | Withdraw Wallet Integer Integer + | BuyTokens Wallet Wallet Integer deriving (Show, Eq) data ContractInstanceKey TSModel w s e where - StartKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSStartSchema' Text - UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text + OperateKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text + UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text arbitraryAction _ = oneof $ (Start <$> genSeller) : - [ (\v w p -> TSAction v w $ SetPrice p) <$> genSeller <*> genUser <*> arbitrary ] ++ - [ (\v w n -> TSAction v w $ AddTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++ - [ (\v w n -> TSAction v w $ BuyTokens n) <$> genSeller <*> genUser <*> arbitrary ] ++ - [ (\v w n l -> TSAction v w $ Withdraw n l) <$> genSeller <*> genUser <*> arbitrary <*> arbitrary ] + [ SetPrice <$> genSeller <*> genNonNeg ] ++ + [ AddTokens <$> genSeller <*> genNonNeg ] ++ + [ Withdraw <$> genSeller <*> genNonNeg <*> genNonNeg ] ++ + [ BuyTokens <$> genSeller <*> genUser <*> genNonNeg ] initialState = TSModel Map.empty @@ -69,21 +74,21 @@ instance ContractModel TSModel where (tsModel . at w) $= Just (TSState 0 0 0) wait 1 - nextState (TSAction v w (SetPrice p)) = when (v == w) $ do - (tsModel . ix v . tssPrice) $= p + nextState (SetPrice w p) = do + (tsModel . ix w . tssPrice) $= p wait 1 - nextState (TSAction v w (AddTokens n)) = do - started <- hasStarted v -- has the token sale started? + nextState (AddTokens w n) = do + started <- hasStarted w -- has the token sale started? when (n > 0 && started) $ do bc <- askModelState $ view $ balanceChange w - let token = tokens Map.! v - when (assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give? + let token = tokens Map.! w + when (tokenAmt + assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give? withdraw w $ assetClassValue token n - (tsModel . ix v . tssToken) $~ (+ n) + (tsModel . ix w . tssToken) $~ (+ n) wait 1 - nextState (TSAction v w (BuyTokens n)) = do + nextState (BuyTokens v w n) = do when (n > 0) $ do m <- getTSState v case m of @@ -94,22 +99,27 @@ instance ContractModel TSModel where withdraw w $ lovelaceValueOf l deposit w $ assetClassValue (tokens Map.! v) n (tsModel . ix v . tssLovelace) $~ (+ l) - (tsModel . ix v . tssToken) $~ (+ (- n)) + (tsModel . ix v . tssToken) $~ (+ (- n)) _ -> return () wait 1 - nextState (TSAction v w (Withdraw n l)) = when (v == w) $ do - withdraw w $ lovelaceValueOf l <> assetClassValue (tokens Map.! v) n - (tsModel . ix v . tssLovelace) $~ (+ (- l)) - (tsModel . ix v . tssToken) $~ (+ (- n)) + nextState (Withdraw w n l) = do + m <- getTSState w + case m of + Just t + | t ^. tssToken >= n && t ^. tssLovelace >= l -> do + deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n + (tsModel . ix w . tssLovelace) $~ (+ (- l)) + (tsModel . ix w . tssToken) $~ (+ (- n)) + _ -> return () wait 1 perform h _ cmd = case cmd of - (Start w) -> callEndpoint @"start" (h $ StartKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1 - (TSAction v w (SetPrice p)) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1 - (TSAction v w (AddTokens n)) -> callEndpoint @"add tokens" (h $ UseKey v w) n >> delay 1 - (TSAction v w (BuyTokens n)) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 - (TSAction v w (Withdraw n l)) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1 + (Start w) -> callEndpoint @"start" (h $ OperateKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1 + (SetPrice w p) -> callEndpoint @"set price" (h $ OperateKey w) p >> delay 1 + (AddTokens w n) -> callEndpoint @"add tokens" (h $ OperateKey w) n >> delay 1 + (Withdraw w n l) -> callEndpoint @"withdraw" (h $ OperateKey w) (n, l) >> delay 1 + (BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 precondition s (Start w) = isNothing $ getTSState' s w precondition _ _ = True @@ -163,15 +173,21 @@ delay = void . waitNSlots . fromIntegral instanceSpec :: [ContractInstanceSpec TSModel] instanceSpec = - [ContractInstanceSpec (StartKey w) w $ startTS'' | w <- [w1, w2]] ++ + [ContractInstanceSpec (OperateKey w) w $ operateTS'' | w <- [w1, w2]] ++ [ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]] genSeller, genUser :: Gen Wallet genSeller = elements [w1, w2] genUser = elements [w3, w4] +genNonNeg :: Gen Integer +genNonNeg = getNonNegative <$> arbitrary + +tokenAmt :: Integer +tokenAmt = 1_000 + prop_TS :: Actions TSModel -> Property -prop_TS = propRunActionsWithOptions +prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions (defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d)) instanceSpec (const $ pure True) @@ -180,7 +196,7 @@ prop_TS = propRunActionsWithOptions d = Map.fromList $ [ ( w , lovelaceValueOf 1000_000_000 <> (nfts Map.! w) <> - mconcat [assetClassValue t 1000 | t <- Map.elems tokens]) + mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens]) | w <- [w1, w2] ] ++ [(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]] @@ -188,3 +204,14 @@ prop_TS = propRunActionsWithOptions test :: IO () test = quickCheck prop_TS + +unitTest :: IO () +unitTest = quickCheck $ withMaxSuccess 1 $ prop_TS $ Actions + [ Start (Wallet 1), + SetPrice (Wallet 1) 2, + AddTokens (Wallet 1) 4, + BuyTokens (Wallet 1) (Wallet 3) 4, + AddTokens (Wallet 1) 6, + Withdraw (Wallet 1) 2 7 + ] + diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index 4ec5fef..5ad60f9 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -15,11 +15,11 @@ module Week08.TokenSale ( TokenSale (..) , TSRedeemer (..) , nftName - , TSStartSchema - , TSStartSchema' + , TSOperateSchema + , TSOperateSchema' , TSUseSchema - , startTS' - , startTS'' + , operateTS' + , operateTS'' , useTS ) where @@ -65,18 +65,19 @@ lovelaces = Ada.getLovelace . Ada.fromValue {-# INLINABLE transition #-} transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) transition ts s r = case (stateValue s, stateData s, r) of - (v, _, SetPrice p) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p (v <> nft (negate 1)) - ) - (v, p, AddTokens n) -> Just ( mempty - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n - ) - (v, p, BuyTokens n) -> Just ( mempty - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) - ) - (v, p, Withdraw n l) -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) - ) + (v, _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p (v <> nft (negate 1)) + ) + (v, p, AddTokens n) | n > 0 -> Just ( mempty + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n + ) + (v, p, BuyTokens n) | n > 0 -> Just ( mempty + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) + ) + (v, p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) + , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) + ) + _ -> Nothing where nft :: Integer -> Value nft = assetClassValue (tsNFT ts) @@ -117,7 +118,7 @@ mapErrorSM = mapError $ pack . show nftName :: TokenName nftName = "NFT" -startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text () +startTS :: HasBlockchainActions s => Maybe CurrencySymbol -> AssetClass -> Contract (Last TokenSale) s Text TokenSale startTS mcs token = do pkh <- pubKeyHash <$> Contract.ownPubKey cs <- case mcs of @@ -132,12 +133,13 @@ startTS mcs token = do void $ mapErrorSM $ runInitialise client 0 mempty tell $ Last $ Just ts logInfo $ "started token sale " ++ show ts + return ts setPrice :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () setPrice ts p = void $ mapErrorSM $ runStep (tsClient ts) $ SetPrice p addTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () -addTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ AddTokens n +addTokens ts n = void (mapErrorSM $ runStep (tsClient ts) $ AddTokens n) buyTokens :: HasBlockchainActions s => TokenSale -> Integer -> Contract w s Text () buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n @@ -145,28 +147,44 @@ buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n withdraw :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text () withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l -type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) -type TSStartSchema' = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName) -type TSUseSchema = BlockchainActions +type TSOperateSchema = BlockchainActions + .\/ Endpoint "start" (CurrencySymbol, TokenName) .\/ Endpoint "set price" Integer .\/ Endpoint "add tokens" Integer - .\/ Endpoint "buy tokens" Integer .\/ Endpoint "withdraw" (Integer, Integer) +type TSOperateSchema' = BlockchainActions + .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName) + .\/ Endpoint "set price" Integer + .\/ Endpoint "add tokens" Integer + .\/ Endpoint "withdraw" (Integer, Integer) +type TSUseSchema = BlockchainActions .\/ Endpoint "buy tokens" Integer -startTS' :: Contract (Last TokenSale) TSStartSchema Text () -startTS' = start >> startTS' +operateTS :: forall s. + ( HasBlockchainActions s + , HasEndpoint "set price" Integer s + , HasEndpoint "add tokens" Integer s + , HasEndpoint "withdraw" (Integer, Integer) s + ) + => Maybe CurrencySymbol + -> CurrencySymbol + -> TokenName + -> Contract (Last TokenSale) s Text () +operateTS mcs cs tn = startTS mcs (AssetClass (cs, tn)) >>= go where - start = endpoint @"start" >>= startTS Nothing . AssetClass + go :: TokenSale -> Contract (Last TokenSale) s Text () + go ts = (setPrice' `select` addTokens' `select` withdraw') >> go ts + where + setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts + addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts + withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) -startTS'' :: Contract (Last TokenSale) TSStartSchema' Text () -startTS'' = start >> startTS'' - where - start = endpoint @"start" >>= \(cs1, cs2, tn) -> startTS (Just cs1) $ AssetClass (cs2, tn) +operateTS' :: Contract (Last TokenSale) TSOperateSchema Text () +operateTS' = endpoint @"start" >>= uncurry (operateTS Nothing) + +operateTS'' :: Contract (Last TokenSale) TSOperateSchema' Text () +operateTS'' = endpoint @"start" >>= \(cs1, cs2, tn) -> operateTS (Just cs1) cs2 tn useTS :: TokenSale -> Contract () TSUseSchema Text () -useTS ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useTS ts +useTS ts = buyTokens' >> useTS ts where - setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts - addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts - withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/src/Week08/TraceTokenSale.hs index 6616282..c7e1a68 100644 --- a/code/week08/src/Week08/TraceTokenSale.hs +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -56,31 +56,24 @@ token2 = AssetClass (currency2, name2) myTrace :: EmulatorTrace () myTrace = do - h <- activateContractWallet (Wallet 1) startTS' - callEndpoint @"start" h (currency1, name1) + h1 <- activateContractWallet (Wallet 1) operateTS' + callEndpoint @"start" h1 (currency1, name1) void $ Emulator.waitNSlots 5 - Last m <- observableState h + Last m <- observableState h1 case m of Nothing -> Extras.logError @String "error starting token sale" Just ts -> do Extras.logInfo $ "started token sale " ++ show ts - h1 <- activateContractWallet (Wallet 1) $ useTS ts h2 <- activateContractWallet (Wallet 2) $ useTS ts h3 <- activateContractWallet (Wallet 3) $ useTS ts callEndpoint @"set price" h1 1_000_000 void $ Emulator.waitNSlots 5 - callEndpoint @"set price" h2 2_000_000 - void $ Emulator.waitNSlots 5 - callEndpoint @"add tokens" h1 100 void $ Emulator.waitNSlots 5 - callEndpoint @"add tokens" h2 10 - void $ Emulator.waitNSlots 5 - callEndpoint @"buy tokens" h2 20 void $ Emulator.waitNSlots 5 @@ -89,6 +82,3 @@ myTrace = do callEndpoint @"withdraw" h1 (40, 10_000_000) void $ Emulator.waitNSlots 5 - - callEndpoint @"withdraw" h2 (40, 10_000_000) - void $ Emulator.waitNSlots 5 From b55dde066d9e1d2e81c2d3acd3b03623e3b13870 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 25 May 2021 21:31:41 +0200 Subject: [PATCH 05/11] bumped Plutus dependency --- code/week08/cabal.project | 2 +- code/week08/src/Week08/TokenSale.hs | 2 +- code/week08/src/Week08/TraceTokenSale.hs | 1 + 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/code/week08/cabal.project b/code/week08/cabal.project index 17ccfce..711f268 100644 --- a/code/week08/cabal.project +++ b/code/week08/cabal.project @@ -25,7 +25,7 @@ source-repository-package plutus-use-cases prettyprinter-configurable quickcheck-dynamic - tag: b1894eb48d3d9c9b7acd83dd39f27b6b01d4a09e + tag: ae35c4b8fe66dd626679bd2951bd72190e09a123 -- The following sections are copied from the 'plutus' repository cabal.project at the revision -- given above. diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index 5ad60f9..93b9b00 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -38,7 +38,7 @@ import Ledger.Ada as Ada import Ledger.Constraints as Constraints import qualified Ledger.Typed.Scripts as Scripts import Ledger.Value -import Prelude (Semigroup (..)) +import Prelude (Semigroup (..), Show (..), uncurry) import qualified Prelude data TokenSale = TokenSale diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/src/Week08/TraceTokenSale.hs index c7e1a68..36e1990 100644 --- a/code/week08/src/Week08/TraceTokenSale.hs +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -24,6 +24,7 @@ import Ledger.Value import Ledger.Ada as Ada import Plutus.Trace.Emulator as Emulator import PlutusTx.Prelude +import Prelude (IO, String, Show (..)) import Wallet.Emulator.Wallet import Week08.TokenSale From f1664d6c3153fdd1a4474984eefe4de2e83a5ee5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 25 May 2021 22:49:40 +0200 Subject: [PATCH 06/11] tests with multiple contract instances per wallet --- code/week08/src/Week08/TestTokenSale.hs | 131 +++++++++++------------ code/week08/src/Week08/TokenSale.hs | 60 ++++------- code/week08/src/Week08/TraceTokenSale.hs | 30 +++--- 3 files changed, 98 insertions(+), 123 deletions(-) diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/src/Week08/TestTokenSale.hs index 036cc05..291cea9 100644 --- a/code/week08/src/Week08/TestTokenSale.hs +++ b/code/week08/src/Week08/TestTokenSale.hs @@ -22,6 +22,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (isJust, isNothing) import Data.Monoid (Last (..)) +import Data.String (IsString (..)) import Data.Text (Text) import Plutus.Contract.Test import Plutus.Contract.Test.ContractModel @@ -31,7 +32,7 @@ import Ledger.Ada as Ada import Ledger.Value import Test.QuickCheck -import Week08.TokenSale (TokenSale (..), TSOperateSchema', TSUseSchema, useTS, operateTS'', nftName) +import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName) data TSState = TSState { _tssPrice :: !Integer @@ -50,22 +51,24 @@ instance ContractModel TSModel where data Action TSModel = Start Wallet - | SetPrice Wallet Integer - | AddTokens Wallet Integer - | Withdraw Wallet Integer Integer + | SetPrice Wallet Wallet Integer + | AddTokens Wallet Wallet Integer + | Withdraw Wallet Wallet Integer Integer | BuyTokens Wallet Wallet Integer deriving (Show, Eq) data ContractInstanceKey TSModel w s e where - OperateKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSOperateSchema' Text - UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text + StartKey :: Wallet -> ContractInstanceKey TSModel (Last TokenSale) TSStartSchema' Text + UseKey :: Wallet -> Wallet -> ContractInstanceKey TSModel () TSUseSchema Text + + instanceTag key _ = fromString $ "instance tag for: " ++ show key arbitraryAction _ = oneof $ - (Start <$> genSeller) : - [ SetPrice <$> genSeller <*> genNonNeg ] ++ - [ AddTokens <$> genSeller <*> genNonNeg ] ++ - [ Withdraw <$> genSeller <*> genNonNeg <*> genNonNeg ] ++ - [ BuyTokens <$> genSeller <*> genUser <*> genNonNeg ] + (Start <$> genWallet) : + [ SetPrice <$> genWallet <*> genWallet <*> genNonNeg ] ++ + [ AddTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ + [ BuyTokens <$> genWallet <*> genWallet <*> genNonNeg ] ++ + [ Withdraw <$> genWallet <*> genWallet <*> genNonNeg <*> genNonNeg ] initialState = TSModel Map.empty @@ -74,18 +77,19 @@ instance ContractModel TSModel where (tsModel . at w) $= Just (TSState 0 0 0) wait 1 - nextState (SetPrice w p) = do - (tsModel . ix w . tssPrice) $= p + nextState (SetPrice v w p) = do + when (v == w) $ + (tsModel . ix v . tssPrice) $= p wait 1 - nextState (AddTokens w n) = do - started <- hasStarted w -- has the token sale started? + nextState (AddTokens v w n) = do + started <- hasStarted v -- has the token sale started? when (n > 0 && started) $ do bc <- askModelState $ view $ balanceChange w - let token = tokens Map.! w + let token = tokens Map.! v when (tokenAmt + assetClassValueOf bc token >= n) $ do -- does the wallet have the tokens to give? withdraw w $ assetClassValue token n - (tsModel . ix w . tssToken) $~ (+ n) + (tsModel . ix v . tssToken) $~ (+ n) wait 1 nextState (BuyTokens v w n) = do @@ -103,23 +107,24 @@ instance ContractModel TSModel where _ -> return () wait 1 - nextState (Withdraw w n l) = do - m <- getTSState w - case m of - Just t - | t ^. tssToken >= n && t ^. tssLovelace >= l -> do - deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n - (tsModel . ix w . tssLovelace) $~ (+ (- l)) - (tsModel . ix w . tssToken) $~ (+ (- n)) - _ -> return () + nextState (Withdraw v w n l) = do + when (v == w) $ do + m <- getTSState v + case m of + Just t + | t ^. tssToken >= n && t ^. tssLovelace >= l -> do + deposit w $ lovelaceValueOf l <> assetClassValue (tokens Map.! w) n + (tsModel . ix v . tssLovelace) $~ (+ (- l)) + (tsModel . ix v . tssToken) $~ (+ (- n)) + _ -> return () wait 1 perform h _ cmd = case cmd of - (Start w) -> callEndpoint @"start" (h $ OperateKey w) (css Map.! w, tokenCurrency, tokenNames Map.! w) >> delay 1 - (SetPrice w p) -> callEndpoint @"set price" (h $ OperateKey w) p >> delay 1 - (AddTokens w n) -> callEndpoint @"add tokens" (h $ OperateKey w) n >> delay 1 - (Withdraw w n l) -> callEndpoint @"withdraw" (h $ OperateKey w) (n, l) >> delay 1 - (BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 + (Start w) -> callEndpoint @"start" (h $ StartKey w) (nftCurrencies Map.! w, tokenCurrencies Map.! w, tokenNames Map.! w) >> delay 1 + (SetPrice v w p) -> callEndpoint @"set price" (h $ UseKey v w) p >> delay 1 + (AddTokens v w n) -> callEndpoint @"add tokens" (h $ UseKey v w) n >> delay 1 + (BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 + (Withdraw v w n l) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1 precondition s (Start w) = isNothing $ getTSState' s w precondition _ _ = True @@ -138,34 +143,36 @@ getTSState v = do hasStarted :: Wallet -> Spec TSModel Bool hasStarted v = isJust <$> getTSState v -w1, w2, w3, w4 :: Wallet +w1, w2 :: Wallet w1 = Wallet 1 w2 = Wallet 2 -w3 = Wallet 3 -w4 = Wallet 4 - -tokenCurrency :: CurrencySymbol -tokenCurrency = "ff" - -tokenNames :: Map Wallet TokenName -tokenNames = Map.fromList [(w1, "A"), (w2, "B")] - -tokens :: Map Wallet AssetClass -tokens = (\tn -> AssetClass (tokenCurrency, tn)) <$> tokenNames wallets :: [Wallet] -wallets = [w1, w2, w3, w4] +wallets = [w1, w2] -css :: Map Wallet CurrencySymbol -css = Map.fromList [(w1, "01"), (w2, "02")] +tokenCurrencies, nftCurrencies :: Map Wallet CurrencySymbol +tokenCurrencies = Map.fromList $ zip wallets ["aa", "bb"] +nftCurrencies = Map.fromList $ zip wallets ["01", "02"] + +tokenNames :: Map Wallet TokenName +tokenNames = Map.fromList $ zip wallets ["A", "B"] + +tokens :: Map Wallet AssetClass +tokens = Map.fromList [(w, AssetClass (tokenCurrencies Map.! w, tokenNames Map.! w)) | w <- wallets] + +nftAssets :: Map Wallet AssetClass +nftAssets = Map.fromList [(w, AssetClass (nftCurrencies Map.! w, nftName)) | w <- wallets] nfts :: Map Wallet Value -nfts = (\cs -> assetClassValue (AssetClass (cs, nftName)) 1) <$> css +nfts = Map.fromList [(w, assetClassValue (nftAssets Map.! w) 1) | w <- wallets] tss :: Map Wallet TokenSale tss = Map.fromList - [ (w, TokenSale (pubKeyHash $ walletPubKey w) (tokens Map.! w) $ AssetClass (css Map.! w, nftName)) - | w <- [w1, w2] + [ (w, TokenSale { tsSeller = pubKeyHash $ walletPubKey w + , tsToken = tokens Map.! w + , tsNFT = nftAssets Map.! w + }) + | w <- wallets ] delay :: Int -> EmulatorTrace () @@ -173,12 +180,11 @@ delay = void . waitNSlots . fromIntegral instanceSpec :: [ContractInstanceSpec TSModel] instanceSpec = - [ContractInstanceSpec (OperateKey w) w $ operateTS'' | w <- [w1, w2]] ++ - [ContractInstanceSpec (UseKey v w) w $ useTS $ tss Map.! v | v <- [w1, w2], w <- [w3, w4]] + [ContractInstanceSpec (StartKey w) w startEndpoint' | w <- wallets] ++ + [ContractInstanceSpec (UseKey v w) w $ useEndpoints $ tss Map.! v | v <- wallets, w <- wallets] -genSeller, genUser :: Gen Wallet -genSeller = elements [w1, w2] -genUser = elements [w3, w4] +genWallet :: Gen Wallet +genWallet = elements wallets genNonNeg :: Gen Integer genNonNeg = getNonNegative <$> arbitrary @@ -197,21 +203,8 @@ prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions , lovelaceValueOf 1000_000_000 <> (nfts Map.! w) <> mconcat [assetClassValue t tokenAmt | t <- Map.elems tokens]) - | w <- [w1, w2] - ] ++ - [(w, lovelaceValueOf 1000_000_000) | w <- [w3, w4]] - + | w <- wallets + ] test :: IO () test = quickCheck prop_TS - -unitTest :: IO () -unitTest = quickCheck $ withMaxSuccess 1 $ prop_TS $ Actions - [ Start (Wallet 1), - SetPrice (Wallet 1) 2, - AddTokens (Wallet 1) 4, - BuyTokens (Wallet 1) (Wallet 3) 4, - AddTokens (Wallet 1) 6, - Withdraw (Wallet 1) 2 7 - ] - diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index 93b9b00..e84884b 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -15,12 +15,12 @@ module Week08.TokenSale ( TokenSale (..) , TSRedeemer (..) , nftName - , TSOperateSchema - , TSOperateSchema' + , TSStartSchema + , TSStartSchema' , TSUseSchema - , operateTS' - , operateTS'' - , useTS + , startEndpoint + , startEndpoint' + , useEndpoints ) where import Control.Monad hiding (fmap) @@ -147,44 +147,30 @@ buyTokens ts n = void $ mapErrorSM $ runStep (tsClient ts) $ BuyTokens n withdraw :: HasBlockchainActions s => TokenSale -> Integer -> Integer -> Contract w s Text () withdraw ts n l = void $ mapErrorSM $ runStep (tsClient ts) $ Withdraw n l -type TSOperateSchema = BlockchainActions +type TSStartSchema = BlockchainActions .\/ Endpoint "start" (CurrencySymbol, TokenName) +type TSStartSchema' = BlockchainActions + .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName) +type TSUseSchema = BlockchainActions .\/ Endpoint "set price" Integer .\/ Endpoint "add tokens" Integer + .\/ Endpoint "buy tokens" Integer .\/ Endpoint "withdraw" (Integer, Integer) -type TSOperateSchema' = BlockchainActions - .\/ Endpoint "start" (CurrencySymbol, CurrencySymbol, TokenName) - .\/ Endpoint "set price" Integer - .\/ Endpoint "add tokens" Integer - .\/ Endpoint "withdraw" (Integer, Integer) -type TSUseSchema = BlockchainActions .\/ Endpoint "buy tokens" Integer -operateTS :: forall s. - ( HasBlockchainActions s - , HasEndpoint "set price" Integer s - , HasEndpoint "add tokens" Integer s - , HasEndpoint "withdraw" (Integer, Integer) s - ) - => Maybe CurrencySymbol - -> CurrencySymbol - -> TokenName - -> Contract (Last TokenSale) s Text () -operateTS mcs cs tn = startTS mcs (AssetClass (cs, tn)) >>= go +startEndpoint :: Contract (Last TokenSale) TSStartSchema Text () +startEndpoint = startTS' >> startEndpoint where - go :: TokenSale -> Contract (Last TokenSale) s Text () - go ts = (setPrice' `select` addTokens' `select` withdraw') >> go ts - where - setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts - addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts - withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) + startTS' = handleError logError $ endpoint @"start" >>= void . startTS Nothing . AssetClass -operateTS' :: Contract (Last TokenSale) TSOperateSchema Text () -operateTS' = endpoint @"start" >>= uncurry (operateTS Nothing) - -operateTS'' :: Contract (Last TokenSale) TSOperateSchema' Text () -operateTS'' = endpoint @"start" >>= \(cs1, cs2, tn) -> operateTS (Just cs1) cs2 tn - -useTS :: TokenSale -> Contract () TSUseSchema Text () -useTS ts = buyTokens' >> useTS ts +startEndpoint' :: Contract (Last TokenSale) TSStartSchema' Text () +startEndpoint' = startTS' >> startEndpoint' where + startTS' = handleError logError $ endpoint @"start" >>= \(cs1, cs2, tn) -> void $ startTS (Just cs1) $ AssetClass (cs2, tn) + +useEndpoints :: TokenSale -> Contract () TSUseSchema Text () +useEndpoints ts = (setPrice' `select` addTokens' `select` buyTokens' `select` withdraw') >> useEndpoints ts + where + setPrice' = handleError logError $ endpoint @"set price" >>= setPrice ts + addTokens' = handleError logError $ endpoint @"add tokens" >>= addTokens ts buyTokens' = handleError logError $ endpoint @"buy tokens" >>= buyTokens ts + withdraw' = handleError logError $ endpoint @"withdraw" >>= uncurry (withdraw ts) diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/src/Week08/TraceTokenSale.hs index 36e1990..9820575 100644 --- a/code/week08/src/Week08/TraceTokenSale.hs +++ b/code/week08/src/Week08/TraceTokenSale.hs @@ -39,35 +39,31 @@ test = runEmulatorTraceIO' def emCfg myTrace ] v :: Value - v = Ada.lovelaceValueOf 1000_000_000 - <> assetClassValue token1 1000 - <> assetClassValue token2 1000 + v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 -currency1, currency2 :: CurrencySymbol -currency1 = "aa" -currency2 = "bb" +currency :: CurrencySymbol +currency = "aa" -name1, name2 :: TokenName -name1 = "A" -name2 = "B" +name :: TokenName +name = "A" -token1, token2 :: AssetClass -token1 = AssetClass (currency1, name1) -token2 = AssetClass (currency2, name2) +token :: AssetClass +token = AssetClass (currency, name) myTrace :: EmulatorTrace () myTrace = do - h1 <- activateContractWallet (Wallet 1) operateTS' - callEndpoint @"start" h1 (currency1, name1) + h <- activateContractWallet (Wallet 1) startEndpoint + callEndpoint @"start" h (currency, name) void $ Emulator.waitNSlots 5 - Last m <- observableState h1 + Last m <- observableState h case m of Nothing -> Extras.logError @String "error starting token sale" Just ts -> do Extras.logInfo $ "started token sale " ++ show ts - h2 <- activateContractWallet (Wallet 2) $ useTS ts - h3 <- activateContractWallet (Wallet 3) $ useTS ts + h1 <- activateContractWallet (Wallet 1) $ useEndpoints ts + h2 <- activateContractWallet (Wallet 2) $ useEndpoints ts + h3 <- activateContractWallet (Wallet 3) $ useEndpoints ts callEndpoint @"set price" h1 1_000_000 void $ Emulator.waitNSlots 5 From 64d795fbb256ab83d24a183f560a39cae25cf0a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 26 May 2021 00:34:34 +0200 Subject: [PATCH 07/11] test suite --- code/week08/hie.yaml | 2 ++ .../plutus-pioneer-program-week08.cabal | 30 ++++++++++++---- code/week08/test/Spec.hs | 16 +++++++++ .../TestTokenSale.hs => test/Spec/Model.hs} | 19 ++++++++--- .../TraceTokenSale.hs => test/Spec/Trace.hs} | 34 +++++++++++++------ 5 files changed, 80 insertions(+), 21 deletions(-) create mode 100644 code/week08/test/Spec.hs rename code/week08/{src/Week08/TestTokenSale.hs => test/Spec/Model.hs} (93%) rename code/week08/{src/Week08/TraceTokenSale.hs => test/Spec/Trace.hs} (72%) diff --git a/code/week08/hie.yaml b/code/week08/hie.yaml index d60a69e..7dc90d6 100644 --- a/code/week08/hie.yaml +++ b/code/week08/hie.yaml @@ -2,3 +2,5 @@ cradle: cabal: - path: "./src" component: "lib:plutus-pioneer-program-week08" + - path: "./test" + component: "test:plutus-pioneer-program-week08-tests" diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal index 28c7d22..b315d79 100644 --- a/code/week08/plutus-pioneer-program-week08.cabal +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -11,14 +11,9 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week08.TokenSale - , Week08.TestTokenSale - , Week08.TraceTokenSale build-depends: aeson , base ^>=4.14.1.0 , containers - , data-default - , freer-extras - , lens , playground-common , plutus-contract , plutus-ledger @@ -27,7 +22,30 @@ library , plutus-tx , plutus-use-cases , prettyprinter - , QuickCheck , text default-language: Haskell2010 ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise + +test-suite plutus-pioneer-program-week08-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + other-modules: Spec.Model + , Spec.Trace + default-language: Haskell2010 + ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + build-depends: base ^>=4.14.1.0 + , containers + , data-default + , freer-extras + , lens + , plutus-contract + , plutus-ledger + , plutus-pioneer-program-week08 + , plutus-tx + , QuickCheck + , tasty + , tasty-quickcheck + , text + if !(impl(ghcjs) || os(ghcjs)) + build-depends: plutus-tx-plugin -any diff --git a/code/week08/test/Spec.hs b/code/week08/test/Spec.hs new file mode 100644 index 0000000..8d6a170 --- /dev/null +++ b/code/week08/test/Spec.hs @@ -0,0 +1,16 @@ +module Main + ( main + ) where + +import qualified Spec.Model +import qualified Spec.Trace +import Test.Tasty + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "token sale" + [ Spec.Trace.tests + , Spec.Model.tests + ] diff --git a/code/week08/src/Week08/TestTokenSale.hs b/code/week08/test/Spec/Model.hs similarity index 93% rename from code/week08/src/Week08/TestTokenSale.hs rename to code/week08/test/Spec/Model.hs index 291cea9..597ccd3 100644 --- a/code/week08/src/Week08/TestTokenSale.hs +++ b/code/week08/test/Spec/Model.hs @@ -14,7 +14,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week08.TestTokenSale where +module Spec.Model + ( tests + , test + ) where import Control.Lens hiding (elements) import Control.Monad (void, when) @@ -31,6 +34,8 @@ import Ledger hiding (singleton) import Ledger.Ada as Ada import Ledger.Value import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck import Week08.TokenSale (TokenSale (..), TSStartSchema', TSUseSchema, startEndpoint', useEndpoints, nftName) @@ -47,6 +52,9 @@ newtype TSModel = TSModel {_tsModel :: Map Wallet TSState} makeLenses ''TSModel +tests :: TestTree +tests = testProperty "token sale model" prop_TS + instance ContractModel TSModel where data Action TSModel = @@ -126,8 +134,11 @@ instance ContractModel TSModel where (BuyTokens v w n) -> callEndpoint @"buy tokens" (h $ UseKey v w) n >> delay 1 (Withdraw v w n l) -> callEndpoint @"withdraw" (h $ UseKey v w) (n, l) >> delay 1 - precondition s (Start w) = isNothing $ getTSState' s w - precondition _ _ = True + precondition s (Start w) = isNothing $ getTSState' s w + precondition s (SetPrice v _ _) = isJust $ getTSState' s v + precondition s (AddTokens v _ _) = isJust $ getTSState' s v + precondition s (BuyTokens v _ _) = isJust $ getTSState' s v + precondition s (Withdraw v _ _ _) = isJust $ getTSState' s v deriving instance Eq (ContractInstanceKey TSModel w s e) deriving instance Show (ContractInstanceKey TSModel w s e) @@ -193,7 +204,7 @@ tokenAmt :: Integer tokenAmt = 1_000 prop_TS :: Actions TSModel -> Property -prop_TS = withMaxSuccess 1000 . propRunActionsWithOptions +prop_TS = withMaxSuccess 100 . propRunActionsWithOptions (defaultCheckOptions & emulatorConfig .~ EmulatorConfig (Left d)) instanceSpec (const $ pure True) diff --git a/code/week08/src/Week08/TraceTokenSale.hs b/code/week08/test/Spec/Trace.hs similarity index 72% rename from code/week08/src/Week08/TraceTokenSale.hs rename to code/week08/test/Spec/Trace.hs index 9820575..9796228 100644 --- a/code/week08/src/Week08/TraceTokenSale.hs +++ b/code/week08/test/Spec/Trace.hs @@ -12,8 +12,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week08.TraceTokenSale where +module Spec.Trace + ( tests + , runMyTrace + ) where +import Control.Lens import Control.Monad hiding (fmap) import Control.Monad.Freer.Extras as Extras import Data.Default (Default (..)) @@ -22,24 +26,32 @@ import Data.Monoid (Last (..)) import Ledger import Ledger.Value import Ledger.Ada as Ada +import Plutus.Contract.Test import Plutus.Trace.Emulator as Emulator import PlutusTx.Prelude import Prelude (IO, String, Show (..)) -import Wallet.Emulator.Wallet +import Test.Tasty import Week08.TokenSale -test :: IO () -test = runEmulatorTraceIO' def emCfg myTrace - where - emCfg :: EmulatorConfig - emCfg = EmulatorConfig $ Left $ Map.fromList - [ (Wallet w, v) - | w <- [1 .. 3] - ] +tests :: TestTree +tests = checkPredicateOptions + (defaultCheckOptions & emulatorConfig .~ emCfg) + "token sale trace" + ( walletFundsChange (Wallet 1) (Ada.lovelaceValueOf 10_000_000 <> assetClassValue token (-60)) + .&&. walletFundsChange (Wallet 2) (Ada.lovelaceValueOf (-20_000_000) <> assetClassValue token 20) + .&&. walletFundsChange (Wallet 3) (Ada.lovelaceValueOf (- 5_000_000) <> assetClassValue token 5) + ) + myTrace +runMyTrace :: IO () +runMyTrace = runEmulatorTraceIO' def emCfg myTrace + +emCfg :: EmulatorConfig +emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet w, v) | w <- [1 .. 3]] + where v :: Value - v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 + v = Ada.lovelaceValueOf 1000_000_000 <> assetClassValue token 1000 currency :: CurrencySymbol currency = "aa" From 7d03111171d594c3fd791357484f307b3a9b8fa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 26 May 2021 11:48:18 +0200 Subject: [PATCH 08/11] reformatting --- code/week08/src/Week08/TokenSale.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index e84884b..d05220d 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -66,16 +66,29 @@ lovelaces = Ada.getLovelace . Ada.fromValue transition :: TokenSale -> State Integer -> TSRedeemer -> Maybe (TxConstraints Void Void, State Integer) transition ts s r = case (stateValue s, stateData s, r) of (v, _, SetPrice p) | p >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p (v <> nft (negate 1)) + , State p $ + v <> + nft (negate 1) ) (v, p, AddTokens n) | n > 0 -> Just ( mempty - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) n + , State p $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) n ) (v, p, BuyTokens n) | n > 0 -> Just ( mempty - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (n * p) + , State p $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) (negate n) <> + lovelaceValueOf (n * p) ) (v, p, Withdraw n l) | n >= 0 && l >= 0 -> Just ( Constraints.mustBeSignedBy (tsSeller ts) - , State p $ v <> nft (negate 1) <> assetClassValue (tsToken ts) (negate n) <> lovelaceValueOf (negate l) + , State p $ + v <> + nft (negate 1) <> + assetClassValue (tsToken ts) (negate n) <> + lovelaceValueOf (negate l) ) _ -> Nothing where From a596b3f086bcd40d79ef9abeb43894cc1dd57111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 26 May 2021 12:29:30 +0200 Subject: [PATCH 09/11] reformatting --- code/week08/src/Week08/TokenSale.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/code/week08/src/Week08/TokenSale.hs b/code/week08/src/Week08/TokenSale.hs index d05220d..6c3bee2 100644 --- a/code/week08/src/Week08/TokenSale.hs +++ b/code/week08/src/Week08/TokenSale.hs @@ -127,7 +127,6 @@ mapErrorC = mapError $ pack . show mapErrorSM :: Contract w s SMContractError a -> Contract w s Text a mapErrorSM = mapError $ pack . show - nftName :: TokenName nftName = "NFT" From 175f5c680f8c52f6f7f95e08eb218f056e65ca70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Thu, 27 May 2021 08:27:21 +0200 Subject: [PATCH 10/11] finished code --- .../plutus-pioneer-program-week08.cabal | 6 ++- code/week08/src/Week08/Lens.hs | 40 +++++++++++++++++++ code/week08/src/Week08/QuickCheck.hs | 39 ++++++++++++++++++ code/week08/test/Spec/Model.hs | 1 + 4 files changed, 85 insertions(+), 1 deletion(-) create mode 100644 code/week08/src/Week08/Lens.hs create mode 100644 code/week08/src/Week08/QuickCheck.hs diff --git a/code/week08/plutus-pioneer-program-week08.cabal b/code/week08/plutus-pioneer-program-week08.cabal index b315d79..57590c7 100644 --- a/code/week08/plutus-pioneer-program-week08.cabal +++ b/code/week08/plutus-pioneer-program-week08.cabal @@ -10,10 +10,13 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week08.TokenSale + exposed-modules: Week08.Lens + , Week08.QuickCheck + , Week08.TokenSale build-depends: aeson , base ^>=4.14.1.0 , containers + , lens , playground-common , plutus-contract , plutus-ledger @@ -22,6 +25,7 @@ library , plutus-tx , plutus-use-cases , prettyprinter + , QuickCheck , text default-language: Haskell2010 ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise diff --git a/code/week08/src/Week08/Lens.hs b/code/week08/src/Week08/Lens.hs new file mode 100644 index 0000000..ff6e85d --- /dev/null +++ b/code/week08/src/Week08/Lens.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Week08.Lens where + +import Control.Lens + +newtype Company = Company {_staff :: [Person]} deriving Show + + +data Person = Person + { _name :: String + , _address :: Address + } deriving Show + +newtype Address = Address {_city :: String} deriving Show + +alejandro, lars :: Person +alejandro = Person + { _name = "Alejandro" + , _address = Address {_city = "Zacateca"} + } +lars = Person + { _name = "Lars" + , _address = Address {_city = "Regensburg"} + } + +iohk :: Company +iohk = Company { _staff = [alejandro, lars] } + +goTo :: String -> Company -> Company +goTo there c = c {_staff = map movePerson (_staff c)} + where + movePerson p = p {_address = (_address p) {_city = there}} + +makeLenses ''Company +makeLenses ''Person +makeLenses ''Address + +goTo' :: String -> Company -> Company +goTo' there c = c & staff . each . address . city .~ there diff --git a/code/week08/src/Week08/QuickCheck.hs b/code/week08/src/Week08/QuickCheck.hs new file mode 100644 index 0000000..2eea159 --- /dev/null +++ b/code/week08/src/Week08/QuickCheck.hs @@ -0,0 +1,39 @@ +module Week08.QuickCheck where + +import Test.QuickCheck + +prop_simple :: Bool +prop_simple = 2 + 2 == (4 :: Int) + +-- Insertion sort code: + +-- | Sort a list of integers in ascending order. +-- +-- >>> sort [5,1,9] +-- [1,5,9] +-- +sort :: [Int] -> [Int] -- not correct +sort [] = [] +sort (x:xs) = insert x $ sort xs + +-- | Insert an integer at the right position into an /ascendingly sorted/ +-- list of integers. +-- +-- >>> insert 5 [1,9] +-- [1,5,9] +-- +insert :: Int -> [Int] -> [Int] -- not correct +insert x [] = [x] +insert x (y:ys) | x <= y = x : y : ys + | otherwise = y : insert x ys + +isSorted :: [Int] -> Bool +isSorted [] = True +isSorted [_] = True +isSorted (x : y : ys) = x <= y && isSorted (y : ys) + +prop_sort_sorts :: [Int] -> Bool +prop_sort_sorts xs = isSorted $ sort xs + +prop_sort_preserves_length :: [Int] -> Bool +prop_sort_preserves_length xs = length (sort xs) == length xs diff --git a/code/week08/test/Spec/Model.hs b/code/week08/test/Spec/Model.hs index 597ccd3..d7b55af 100644 --- a/code/week08/test/Spec/Model.hs +++ b/code/week08/test/Spec/Model.hs @@ -17,6 +17,7 @@ module Spec.Model ( tests , test + , TSModel (..) ) where import Control.Lens hiding (elements) From 6845003f8271bee26072eb8e789d0c1f7d9b11f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Thu, 27 May 2021 08:33:05 +0200 Subject: [PATCH 11/11] updated README --- README.md | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/README.md b/README.md index 31a619f..9fc4ee3 100644 --- a/README.md +++ b/README.md @@ -43,6 +43,14 @@ - Commit schemes. - State machines. +- [Lecture #8](https://youtu.be/JMRwkMgaBOg) + + - Another state machine example: token sale. + - Automatic testing using emulator traces. + - Interlude: optics. + - Property based testing with `QuickCheck`. + - Testing Plutus contracts with property based testing. + ## Code Examples - Lecture #1: [English Auction](code/week01) @@ -52,6 +60,7 @@ - Lecture #5: [Minting Policies](code/week05) - Lecture #6: [Oracles](code/week06) - Lecture #7: [State Machines](code/week07) +- Lecture #8: [Testing](code/week08) ## Exercises @@ -97,6 +106,12 @@ - Implement the game of "Rock, Paper, Scissors" using state machines. +- Week #8 + + - Add a new operation `close` to the `TokenSale`-contract that allows the seller to close the contract and + retrieve all remaining funds (including the NFT). + - Modify the tests accordingly. + ## Solutions - Week #2 @@ -126,6 +141,8 @@ ## Some Plutus Modules - [`Plutus.Contract.StateMachine`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Contract/StateMachine.hs), contains types and functions for using state machines. +- [`Plutus.Contract.Test`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Contract/Test.hs), provides various ways to write tests for Plutus contracts. +- [`Plutus.Contract.Test.ContractModel`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Contract/Test/ContractModel.hs), support for property based testing of Plutus contracts. - [`Plutus.PAB.Webserver.API`](https://github.com/input-output-hk/plutus/blob/master/plutus-pab/src/Plutus/PAB/Webserver/API.hs), contains the HTTP-interface provided by the PAB. - [`Plutus.Trace.Emulator`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Trace/Emulator.hs), contains types and functions related to traces. - [`Plutus.V1.Ledger.Ada`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Ada.hs), contains support for the Ada currency.