From 62788264f7bf7f8ba6ce7c32aefa80b5caa23c6d Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Tue, 14 Sep 2021 11:15:51 +0700 Subject: [PATCH 1/6] update backend --- MetaLamp/lending-pool/cabal.project | 114 ++++++++++++------ .../client/scripts/fetch-plutus-purs.sh | 2 +- MetaLamp/lending-pool/nix/pkgs/default.nix | 9 +- .../lending-pool/nix/pkgs/haskell/default.nix | 5 +- .../lending-pool/nix/pkgs/haskell/haskell.nix | 35 +++--- MetaLamp/lending-pool/nix/sources.json | 6 +- MetaLamp/lending-pool/plutus-starter.cabal | 1 + .../src/Ext/Plutus/Ledger/Contexts.hs | 4 +- .../src/Plutus/Abstract/ContractResponse.hs | 27 +++-- .../src/Plutus/Abstract/State/Select.hs | 10 +- .../src/Plutus/Abstract/State/Update.hs | 20 +-- .../src/Plutus/Abstract/TxUtils.hs | 16 +-- .../Contracts/LendingPool/OffChain/AToken.hs | 7 +- .../Contracts/LendingPool/OffChain/Info.hs | 8 +- .../Contracts/LendingPool/OffChain/Owner.hs | 6 +- .../Contracts/LendingPool/OffChain/User.hs | 10 +- .../Contracts/LendingPool/OnChain/AToken.hs | 18 +-- .../LendingPool/OnChain/Core/Logic.hs | 4 +- .../Plutus/Contracts/Service/FungibleToken.hs | 12 +- .../src/Plutus/Contracts/Service/Oracle.hs | 19 +-- .../lending-pool/src/Plutus/PAB/Simulation.hs | 47 ++++---- MetaLamp/lending-pool/test/Fixtures/Init.hs | 2 +- MetaLamp/lending-pool/test/Fixtures/Symbol.hs | 12 +- MetaLamp/lending-pool/test/Spec/Shared.hs | 1 - MetaLamp/lending-pool/test/Utils/Data.hs | 3 +- MetaLamp/lending-pool/test/Utils/Trace.hs | 10 +- 26 files changed, 228 insertions(+), 180 deletions(-) diff --git a/MetaLamp/lending-pool/cabal.project b/MetaLamp/lending-pool/cabal.project index ad1a2aaad..710c15c7a 100644 --- a/MetaLamp/lending-pool/cabal.project +++ b/MetaLamp/lending-pool/cabal.project @@ -1,4 +1,4 @@ -index-state: 2021-04-13T00:00:00Z +index-state: 2021-08-14T00:00:00Z packages: ./. @@ -9,6 +9,7 @@ write-ghc-environment-files: never tests: true benchmarks: true +-- Plutus revision from 2021/08/16 source-repository-package type: git location: https://github.com/input-output-hk/plutus.git @@ -17,6 +18,7 @@ source-repository-package playground-common plutus-core plutus-contract + plutus-chain-index plutus-ledger plutus-ledger-api plutus-tx @@ -26,41 +28,66 @@ source-repository-package prettyprinter-configurable quickcheck-dynamic word-array - tag: plutus-starter-devcontainer/v1.0.6 + tag: plutus-starter-devcontainer/v1.0.8 + -- 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. -package eventful-sql-common - ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances + +-- We never, ever, want this. +write-ghc-environment-files: never + +-- Always build tests and benchmarks. +tests: true +benchmarks: true + +-- The only sensible test display option +test-show-details: streaming allow-newer: - -- 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 + size-based:template-haskell + , ouroboros-consensus-byron:formatting + , beam-core:aeson + , beam-sqlite:aeson + , beam-sqlite:dlist + , beam-migrate:aeson 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 - + singletons < 3.0 + -- bizarre issue: in earlier versions they define their own 'GEq', in newer + -- ones they reuse the one from 'some', but there isn't e.g. a proper version + -- constraint from dependent-sum-template (which is the library we actually use). + , dependent-sum > 0.6.2.0 + +-- 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 --- Drops an instance breaking our code. Should be released to Hackage eventually. +-- These packages appear in our dependency tree and are very slow to build. +-- Empirically, turning off optimization shaves off ~50% build time. +-- It also mildly improves recompilation avoidance. +-- For deve work we don't care about performance so much, so this is okay. +package cardano-ledger-alonzo + optimization: False +package ouroboros-consensus-shelley + optimization: False +package ouroboros-consensus-cardano + optimization: False +package cardano-api + optimization: False + +-- https://github.com/Quid2/flat/pull/22 fixes a potential exception +-- when decoding invalid (e.g. malicious) text literals. source-repository-package type: git - location: https://github.com/Quid2/flat.git - tag: 95e5d7488451e43062ca84d5376b3adcc465f1cd + -- location: https://github.com/Quid2/flat.git + location: https://github.com/michaelpj/flat.git + tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 -- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) source-repository-package @@ -76,25 +103,22 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-crypto.git - tag: ce8f1934e4b6252084710975bd9bbc0a4648ece4 - --- Needs a fix (https://github.com/wenkokke/unlit/pull/11) and a Hackage release -source-repository-package - type: git - location: https://github.com/michaelpj/unlit.git - tag: 9ca1112093c5ffd356fc99c7dafa080e686dd748 + tag: 07397f0e50da97eaa0575d93bee7ac4b2b2576ec source-repository-package type: git location: https://github.com/input-output-hk/cardano-base - tag: a715c7f420770b70bbe95ca51d3dec83866cb1bd + tag: cb0f19c85e5bb5299839ad4ed66af6fa61322cc4 subdir: + base-deriving-via binary binary/test - slotting cardano-crypto-class cardano-crypto-praos cardano-crypto-tests + measures + orphans-deriving-via + slotting strict-containers source-repository-package @@ -108,8 +132,9 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/ouroboros-network - tag: e50613562d6d4a0f933741fcf590b0f69a1eda67 + tag: 877ce057ff6fb086474c8eaad53f2b7f0e0fce6b subdir: + monoidal-synchronisation typed-protocols typed-protocols-examples ouroboros-network @@ -120,23 +145,27 @@ source-repository-package ouroboros-consensus-cardano ouroboros-consensus-shelley io-sim - io-sim-classes + io-classes network-mux source-repository-package type: git location: https://github.com/input-output-hk/iohk-monitoring-framework - tag: 34abfb7f4f5610cabb45396e0496472446a0b2ca + tag: 808724ff8a19a33d0ed06f9ef59fbd900b08553c subdir: iohk-monitoring tracer-transformers contra-tracer + plugins/backend-aggregation plugins/backend-ekg + plugins/backend-monitoring + plugins/backend-trace-forwarder + plugins/scribe-systemd source-repository-package type: git location: https://github.com/input-output-hk/cardano-ledger-specs - tag: a3ef848542961079b7cd53d599e5385198a3035c + tag: d5b184a820853c7ba202efd615b8fadca1acb52c subdir: byron/chain/executable-spec byron/crypto @@ -159,21 +188,34 @@ source-repository-package source-repository-package type: git location: https://github.com/input-output-hk/cardano-node.git - tag: b3cabae6b3bf30a0b1b4e78bc4b67282dabad0a6 + tag: ed11e8b6429d4af1cb2539460e5cb2283a06b2dc subdir: cardano-api + cardano-node + cardano-cli + cardano-config + +source-repository-package + type: git + location: https://github.com/input-output-hk/optparse-applicative + tag: 7497a29cb998721a9068d5725d49461f2bba0e7a source-repository-package type: git location: https://github.com/input-output-hk/Win32-network - tag: 94153b676617f8f33abe8d8182c37377d2784bd1 + tag: 3825d3abf75f83f406c1f7161883c438dac7277d source-repository-package type: git location: https://github.com/input-output-hk/hedgehog-extras - tag: 8bcd3c9dc22cc44f9fcfe161f4638a384fc7a187 + tag: edf6945007177a638fbeb8802397f3a6f4e47c14 source-repository-package type: git location: https://github.com/input-output-hk/goblins tag: cde90a2b27f79187ca8310b6549331e59595e7ba + +source-repository-package + type: git + location: https://github.com/sordina/servant-options + tag: aa9338b1925e7bc5d65bad35f02aec8c20f8365b diff --git a/MetaLamp/lending-pool/client/scripts/fetch-plutus-purs.sh b/MetaLamp/lending-pool/client/scripts/fetch-plutus-purs.sh index 4b185c343..526cde1c4 100755 --- a/MetaLamp/lending-pool/client/scripts/fetch-plutus-purs.sh +++ b/MetaLamp/lending-pool/client/scripts/fetch-plutus-purs.sh @@ -6,4 +6,4 @@ git remote add origin -f https://github.com/input-output-hk/plutus git config core.sparseCheckout true echo 'web-common-plutus/*' >> .git/info/sparse-checkout echo 'web-common/*' >> .git/info/sparse-checkout -git pull origin bd16cc29045ffc7eaa6beaabe3b985a56cb9292a # plutus-starter-devcontainer/v1.0.6 +git pull origin cc7bc06c4344cee6cd59bc170063fd627da25ed3 # plutus-starter-devcontainer/v1.0.8 diff --git a/MetaLamp/lending-pool/nix/pkgs/default.nix b/MetaLamp/lending-pool/nix/pkgs/default.nix index 98ffcd0e2..b1b740d11 100644 --- a/MetaLamp/lending-pool/nix/pkgs/default.nix +++ b/MetaLamp/lending-pool/nix/pkgs/default.nix @@ -11,6 +11,7 @@ let haskell = pkgs.callPackage ./haskell { inherit gitignore-nix sources haskell-nix; inherit compiler-nix-name; # Use the same GHC version as plutus + inherit (pkgs) libsodium-vrf; }; hlint = plutus.plutus.hlint; @@ -35,8 +36,8 @@ let cardano-repo-tool = plutus.plutus.cardano-repo-tool; in -{ - inherit nodejs purs spago purty fix-purty; - inherit haskell hlint cabal-install stylish-haskell fix-stylish-haskell haskell-language-server; +{ + inherit nodejs purs spago purty fix-purty; + inherit haskell hlint cabal-install stylish-haskell fix-stylish-haskell haskell-language-server; inherit cardano-repo-tool; -} +} \ No newline at end of file diff --git a/MetaLamp/lending-pool/nix/pkgs/haskell/default.nix b/MetaLamp/lending-pool/nix/pkgs/haskell/default.nix index 67036b9d5..5200f878e 100644 --- a/MetaLamp/lending-pool/nix/pkgs/haskell/default.nix +++ b/MetaLamp/lending-pool/nix/pkgs/haskell/default.nix @@ -3,6 +3,7 @@ , gitignore-nix , sources , compiler-nix-name +, libsodium-vrf }: let # The Hackage index-state from cabal.project @@ -21,7 +22,7 @@ let # The haskell project created by haskell-nix.cabalProject' project = import ./haskell.nix { - inherit haskell-nix compiler-nix-name gitignore-nix; + inherit lib haskell-nix compiler-nix-name gitignore-nix libsodium-vrf; }; # All the packages defined by our project, including dependencies @@ -32,4 +33,4 @@ let in rec { inherit project projectPackages packages; -} +} \ No newline at end of file diff --git a/MetaLamp/lending-pool/nix/pkgs/haskell/haskell.nix b/MetaLamp/lending-pool/nix/pkgs/haskell/haskell.nix index 517deaa42..68e51bdc8 100644 --- a/MetaLamp/lending-pool/nix/pkgs/haskell/haskell.nix +++ b/MetaLamp/lending-pool/nix/pkgs/haskell/haskell.nix @@ -4,6 +4,8 @@ { haskell-nix , gitignore-nix , compiler-nix-name +, lib +, libsodium-vrf }: let @@ -17,35 +19,34 @@ let inherit compiler-nix-name; sha256map = { - "https://github.com/Quid2/flat.git"."95e5d7488451e43062ca84d5376b3adcc465f1cd" = "06l31x3y93rjpryvlxnpsyq2zyxvb0z6lik6yq2fvh36i5zwvwa3"; - "https://github.com/input-output-hk/plutus.git"."plutus-starter-devcontainer/v1.0.6" = "1jzbcsdrv0b43dj7bwbd1fbk71f7gph6zzb8y29n9cn3j8illnyc"; + "https://github.com/input-output-hk/plutus.git"."plutus-starter-devcontainer/v1.0.8" = "0fas8kv57lyrsn3larvbfgif48d506w73y7g3g0mxfilfsl5nyfz"; + "https://github.com/michaelpj/flat.git"."ee59880f47ab835dbd73bea0847dab7869fc20d8" = "1lrzknw765pz2j97nvv9ip3l1mcpf2zr4n56hwlz0rk7wq7ls4cm"; "https://github.com/shmish111/purescript-bridge.git"."6a92d7853ea514be8b70bab5e72077bf5a510596" = "13j64vv116in3c204qsl1v0ajphac9fqvsjp7x3zzfr7n7g61drb"; "https://github.com/shmish111/servant-purescript.git"."a76104490499aa72d40c2790d10e9383e0dbde63" = "11nxxmi5bw66va7psvrgrw7b7n85fvqgfp58yva99w3v9q3a50v9"; - "https://github.com/input-output-hk/cardano-crypto.git"."ce8f1934e4b6252084710975bd9bbc0a4648ece4" = "1v2laq04piyj511b2m77hxjh9l1yd6k9kc7g6bjala4w3zdwa4ni"; - "https://github.com/michaelpj/unlit.git"."9ca1112093c5ffd356fc99c7dafa080e686dd748" = "145sffn8gbdn6xp9q5b75yd3m46ql5bnc02arzmpfs6wgjslfhff"; - "https://github.com/input-output-hk/cardano-base"."a715c7f420770b70bbe95ca51d3dec83866cb1bd" = "06l06mmb8cd4q37bnvfpgx1c5zgsl4xaf106dqva98738i8asj7j"; + "https://github.com/input-output-hk/cardano-base"."cb0f19c85e5bb5299839ad4ed66af6fa61322cc4" = "0dnkfqcvbifbk3m5pg8kyjqjy0zj1l4vd23p39n6ym4q0bnib1cq"; + "https://github.com/input-output-hk/cardano-crypto.git"."07397f0e50da97eaa0575d93bee7ac4b2b2576ec" = "06sdx5ndn2g722jhpicmg96vsrys89fl81k8290b3lr6b1b0w4m3"; + "https://github.com/input-output-hk/cardano-ledger-specs"."d5b184a820853c7ba202efd615b8fadca1acb52c" = "04k5p6qwmfdza65gl5319r1ahdfwjnyqgzpfxdx0x2g5jcbimar4"; "https://github.com/input-output-hk/cardano-prelude"."fd773f7a58412131512b9f694ab95653ac430852" = "02jddik1yw0222wd6q0vv10f7y8rdgrlqaiy83ph002f9kjx7mh6"; - "https://github.com/input-output-hk/ouroboros-network"."e50613562d6d4a0f933741fcf590b0f69a1eda67" = "0i192ksa69lpzjhzmhd2h1mramkvvikw04pqws18h5dly55f4z3k"; - "https://github.com/input-output-hk/iohk-monitoring-framework"."34abfb7f4f5610cabb45396e0496472446a0b2ca" = "1fdc0a02ipa385dnwa6r6jyc8jlg537i12hflfglkhjs2b7i92gs"; - "https://github.com/input-output-hk/cardano-ledger-specs"."a3ef848542961079b7cd53d599e5385198a3035c" = "02iwn2lcfcfvrnvcqnx586ncdnma23vdqvicxgr4f39vcacalzpd"; - "https://github.com/input-output-hk/cardano-node.git"."b3cabae6b3bf30a0b1b4e78bc4b67282dabad0a6" = "1csmji1bgi45wgrw7kqy19s4bbbpa78kjg3bz7mbiwb8vjgg9kvq"; - "https://github.com/input-output-hk/Win32-network"."94153b676617f8f33abe8d8182c37377d2784bd1" = "0pb7bg0936fldaa5r08nqbxvi2g8pcy4w3c7kdcg7pdgmimr30ss"; - "https://github.com/input-output-hk/hedgehog-extras"."8bcd3c9dc22cc44f9fcfe161f4638a384fc7a187" = "12viwpahjdfvlqpnzdgjp40nw31rvyznnab1hml9afpaxd6ixh70"; "https://github.com/input-output-hk/goblins"."cde90a2b27f79187ca8310b6549331e59595e7ba" = "17c88rbva3iw82yg9srlxjv2ia5wjb9cyqw44hik565f5v9svnyg"; + "https://github.com/sordina/servant-options"."aa9338b1925e7bc5d65bad35f02aec8c20f8365b" = "0vlp3y414f2i4nhmlp1gh9jns8jydbq1mgv8j7vzh62r506slb1j"; + "https://github.com/input-output-hk/iohk-monitoring-framework"."808724ff8a19a33d0ed06f9ef59fbd900b08553c" = "0298dpl29gxzs9as9ha6y0w18hqwc00ipa3hzkxv7nlfrjjz8hmz"; + "https://github.com/input-output-hk/optparse-applicative"."7497a29cb998721a9068d5725d49461f2bba0e7a" = "1gvsrg925vynwgqwplgjmp53vj953qyh3wbdf34pw21c8r47w35r"; + "https://github.com/input-output-hk/ouroboros-network"."877ce057ff6fb086474c8eaad53f2b7f0e0fce6b" = "1kp0qysfy3hl96a3a61rijascq36f1imh3z4jy0vyiygb6qrv47z"; + "https://github.com/input-output-hk/cardano-node.git"."ed11e8b6429d4af1cb2539460e5cb2283a06b2dc" = "1wvr3zzl37i1fn5y9ni027rqw5bhh25z1bacvcaapxxjgdn38lbq"; + "https://github.com/input-output-hk/Win32-network"."3825d3abf75f83f406c1f7161883c438dac7277d" = "19wahfv726fa3mqajpqdqhnl9ica3xmf68i254q45iyjcpj1psqx"; + "https://github.com/input-output-hk/hedgehog-extras"."edf6945007177a638fbeb8802397f3a6f4e47c14" = "0wc7qzkc7j4ns2rz562h6qrx2f8xyq7yjcb7zidnj7f6j0pcd0i9"; }; modules = [ { packages = { - eventful-sql-common = { - # This is needed so evenful-sql-common will build with a newer version of persistent. - ghcOptions = [ "-XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses" ]; - doHaddock = false; - }; - # Broken due to haddock errors. Refer to https://github.com/input-output-hk/plutus/blob/master/nix/pkgs/haskell/haskell.nix plutus-ledger.doHaddock = false; plutus-use-cases.doHaddock = false; + + # See https://github.com/input-output-hk/iohk-nix/pull/488 + cardano-crypto-praos.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; + cardano-crypto-class.components.library.pkgconfig = lib.mkForce [ [ libsodium-vrf ] ]; }; } ]; diff --git a/MetaLamp/lending-pool/nix/sources.json b/MetaLamp/lending-pool/nix/sources.json index 94979120f..3f326f62d 100644 --- a/MetaLamp/lending-pool/nix/sources.json +++ b/MetaLamp/lending-pool/nix/sources.json @@ -5,10 +5,10 @@ "homepage": "", "owner": "input-output-hk", "repo": "plutus", - "rev": "plutus-starter-devcontainer/v1.0.6", - "sha256": "1jzbcsdrv0b43dj7bwbd1fbk71f7gph6zzb8y29n9cn3j8illnyc", + "rev": "plutus-starter-devcontainer/v1.0.8", + "sha256": "0fas8kv57lyrsn3larvbfgif48d506w73y7g3g0mxfilfsl5nyfz", "type": "tarball", - "url": "https://github.com/input-output-hk/plutus/archive/plutus-starter-devcontainer/v1.0.6.tar.gz", + "url": "https://github.com/input-output-hk/plutus/archive/plutus-starter-devcontainer/v1.0.8.tar.gz", "url_template": "https://github.com///archive/.tar.gz" } } diff --git a/MetaLamp/lending-pool/plutus-starter.cabal b/MetaLamp/lending-pool/plutus-starter.cabal index 919955258..4b036fca9 100644 --- a/MetaLamp/lending-pool/plutus-starter.cabal +++ b/MetaLamp/lending-pool/plutus-starter.cabal @@ -30,6 +30,7 @@ library bytestring, containers, text, + data-default, freer-simple, freer-extras, prettyprinter, diff --git a/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs index 6a699ec23..ed0a79878 100644 --- a/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs +++ b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs @@ -38,8 +38,8 @@ findValueByDatumHash dh outs = mconcat $ mapMaybe f outs {-# INLINABLE parseDatum #-} -- | Find datum inside pending transaction and parse it from data -parseDatum :: PlutusTx.IsData a => TxInfo -> DatumHash -> Maybe a -parseDatum txInfo dh = findDatum dh txInfo >>= (PlutusTx.fromData . getDatum) +parseDatum :: (PlutusTx.FromData a, PlutusTx.ToData a) => TxInfo -> DatumHash -> Maybe a +parseDatum txInfo dh = findDatum dh txInfo >>= (PlutusTx.fromBuiltinData . getDatum) {-# INLINABLE valueSpentFrom #-} -- | Concat value of the inputs belonging to the provided public key inside the pending transaction's inputs diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs index 28b87b51e..68965e8eb 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} module Plutus.Abstract.ContractResponse where @@ -70,16 +71,18 @@ withContractResponse :: forall l a p r s. => Proxy l -> (a -> r) -> (p -> Contract (ContractResponse Text r) s Text a) - -> Contract (ContractResponse Text r) s Void () + -> Promise (ContractResponse Text r) s Void () withContractResponse _ g c = do - e <- runError $ do - p <- endpoint @l - _ <- tell ContractPending - errorHandler `handleError` c p - tell $ case e of - Left err -> ContractError err - Right a -> ContractSuccess $ g a - where - errorHandler e = do - logInfo @Text ("Error submiting the transaction: " <> e) - throwError e + handleEndpoint @l $ \case + Left err -> tell $ ContractError err + Right p -> do + _ <- tell ContractPending + e <- runError $ errorHandler `handleError` c p + tell $ case e of + Left err -> ContractError err + Right a -> ContractSuccess $ g a + +errorHandler :: Text -> Contract w s Text b +errorHandler e = do + logInfo @Text ("Error submiting the transaction: " <> e) + throwError e diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs index e85c29670..a1fa57e44 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs @@ -31,16 +31,16 @@ import PlutusTx.Prelude hiding (Semigroup (..), import Prelude (Semigroup (..)) import qualified Prelude -getDatum :: PlutusTx.IsData a => TxOutTx -> Contract w s Text a +getDatum :: (PlutusTx.FromData a, PlutusTx.ToData a) => TxOutTx -> Contract w s Text a getDatum o = case txOutDatumHash $ txOutTxOut o of Nothing -> throwError "datumHash not found" Just h -> case Map.lookup h $ txData $ txOutTxTx o of Nothing -> throwError "datum not found" - Just (Datum e) -> case PlutusTx.fromData e of + Just (Datum e) -> case PlutusTx.fromBuiltinData e of Nothing -> throwError "datum has wrong type" Just d -> return d -getState :: (PlutusTx.IsData datum) => Address -> Contract w s Text [OutputValue datum] +getState :: (PlutusTx.FromData datum, PlutusTx.ToData datum) => Address -> Contract w s Text [OutputValue datum] getState address = do utxos <- utxoAt address traverse getDatum' . Map.toList $ utxos @@ -49,7 +49,7 @@ getState address = do d <- getDatum o pure $ OutputValue oref o d -findOutputsBy :: (PlutusTx.IsData datum) => +findOutputsBy :: (PlutusTx.FromData datum, PlutusTx.ToData datum) => Address -> AssetClass -> (datum -> Maybe a) -> @@ -61,7 +61,7 @@ findOutputsBy address stateToken mapDatum = mapMaybe checkStateToken <$> getStat then fmap (OutputValue oref outTx) (mapDatum datum) else Nothing -findOutputBy :: (PlutusTx.IsData datum) => +findOutputBy :: (PlutusTx.FromData datum, PlutusTx.ToData datum) => Address -> AssetClass -> (datum -> Maybe a) -> diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs index 356a047bd..167871efd 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs @@ -35,7 +35,7 @@ import Plutus.Abstract.OutputValue (OutputValue (..)) import qualified Plutus.Abstract.TxUtils as TxUtils import Plutus.Contract hiding (when) import Plutus.V1.Ledger.Value -import PlutusTx (IsData) +import PlutusTx (FromData, ToData) import qualified PlutusTx import PlutusTx.Prelude hiding (Semigroup (..), unless) @@ -46,8 +46,8 @@ type OwnerToken = AssetClass -- State token can be only be forged when there is an input and output containing an owner token belonging to a script {-# INLINABLE validateStateForging #-} -validateStateForging :: ValidatorHash -> OwnerToken -> TokenName -> ScriptContext -> Bool -validateStateForging ownerScript ownerToken tokenName ctx = traceIfFalse "State forging not authorized" $ +validateStateForging :: ValidatorHash -> OwnerToken -> TokenName -> BuiltinData -> ScriptContext -> Bool +validateStateForging ownerScript ownerToken tokenName _ ctx = traceIfFalse "State forging not authorized" $ hasOneOwnerToken outputValues && hasOneOwnerToken inputValues && hasOneStateToken forgedValue && hasOneStateToken (mconcat outputValues) where txInfo = scriptContextTxInfo ctx @@ -55,14 +55,14 @@ validateStateForging ownerScript ownerToken tokenName ctx = traceIfFalse "State outputValues = snd <$> scriptOutputsAt ownerScript txInfo inputValues = snd <$> scriptInputsAt ownerScript txInfo - forgedValue = txInfoForge txInfo + forgedValue = txInfoMint txInfo hasOneOwnerToken values = assetClassValueOf (mconcat values) ownerToken == 1 hasOneStateToken value = assetClassValueOf value stateToken == 1 -makeStatePolicy :: ValidatorHash -> OwnerToken -> TokenName -> MonetaryPolicy -makeStatePolicy ownerScript ownerToken tokenName = mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| \os ot tn -> Scripts.wrapMonetaryPolicy $ validateStateForging os ot tn||]) +makeStatePolicy :: ValidatorHash -> OwnerToken -> TokenName -> MintingPolicy +makeStatePolicy ownerScript ownerToken tokenName = mkMintingPolicyScript $ + $$(PlutusTx.compile [|| \os ot tn -> Scripts.wrapMintingPolicy $ validateStateForging os ot tn||]) `PlutusTx.applyCode` PlutusTx.liftCode ownerScript `PlutusTx.applyCode` PlutusTx.liftCode ownerToken `PlutusTx.applyCode` PlutusTx.liftCode tokenName @@ -86,7 +86,8 @@ data StateHandle scriptType a = StateHandle { } putState :: - (IsData (DatumType scriptType), IsData (RedeemerType scriptType)) => + (FromData (DatumType scriptType), ToData (DatumType scriptType), + FromData (RedeemerType scriptType), ToData (RedeemerType scriptType)) => PutStateHandle scriptType -> StateHandle scriptType a -> a -> @@ -105,7 +106,8 @@ putState PutStateHandle {..} StateHandle{..} newState = do (assetClassValue ownerToken 1) updateState :: - (IsData (DatumType scriptType), IsData (RedeemerType scriptType)) => + (FromData (DatumType scriptType), ToData (DatumType scriptType), + FromData (RedeemerType scriptType), ToData (RedeemerType scriptType)) => Scripts.TypedValidator scriptType -> StateHandle scriptType a -> OutputValue a -> diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs index 05f55d187..353ff5aae 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs @@ -20,15 +20,13 @@ import qualified Ledger.Constraints as Constraints import qualified Ledger.Constraints.OnChain as Constraints import qualified Ledger.Constraints.TxConstraints as Constraints import Ledger.Typed.Scripts (DatumType, - MonetaryPolicy, + MintingPolicy, RedeemerType, TypedValidator) import qualified Ledger.Typed.Scripts as Scripts import Plutus.Abstract.OutputValue (OutputValue (..)) import Plutus.Contract import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken -import Plutus.V1.Ledger.Contexts (ScriptContext, - scriptCurrencySymbol) import qualified Plutus.V1.Ledger.Scripts as Scripts import Plutus.V1.Ledger.Value (AssetClass (unAssetClass), TokenName (..), @@ -42,7 +40,9 @@ import qualified Prelude type TxPair a = (Constraints.ScriptLookups a, Constraints.TxConstraints (RedeemerType a) (DatumType a)) -type IsScriptData a = (PlutusTx.IsData (RedeemerType a), PlutusTx.IsData (DatumType a)) +type IsScriptData a = ( + PlutusTx.FromData (RedeemerType a), PlutusTx.ToData (RedeemerType a), + PlutusTx.FromData (DatumType a), PlutusTx.ToData (DatumType a)) submitTxPair :: (AsContractError e, IsScriptData a) => TxPair a @@ -50,13 +50,13 @@ submitTxPair :: (AsContractError e, IsScriptData a) => submitTxPair = Prelude.uncurry submitTxConstraintsWith mustForgeValue :: (IsScriptData a) => - MonetaryPolicy + MintingPolicy -> Value -> TxPair a mustForgeValue policy value = (lookups, tx) where - lookups = Constraints.monetaryPolicy policy - tx = Constraints.mustForgeValue value + lookups = Constraints.mintingPolicy policy + tx = Constraints.mustMintValue value mustPayToScript :: (IsScriptData a) => TypedValidator a @@ -78,7 +78,7 @@ mustSpendScriptOutputs script inputs = (lookups, tx) unspent = Map.fromList $ fmap (\(OutputValue ref tx _) -> (ref, tx)) inputs lookups = Constraints.otherScript (Scripts.validatorScript script) <> Constraints.unspentOutputs unspent tx = Prelude.mconcat $ - fmap (\(OutputValue ref _ redeemer) -> Constraints.mustSpendScriptOutput ref (Redeemer $ PlutusTx.toData redeemer)) inputs + fmap (\(OutputValue ref _ redeemer) -> Constraints.mustSpendScriptOutput ref (Redeemer $ PlutusTx.toBuiltinData redeemer)) inputs mustSpendFromScript :: (IsScriptData a) => TypedValidator a diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs index ac1c5c356..7b7a848ab 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs @@ -20,7 +20,7 @@ import Ledger hiding (singleton) import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints import Ledger.Constraints.TxConstraints as Constraints -import Ledger.Typed.Scripts (MonetaryPolicy) +import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.Abstract.OutputValue (OutputValue (..)) import qualified Plutus.Abstract.TxUtils as TxUtils @@ -30,8 +30,9 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, Reserve (..)) import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken -import Plutus.V1.Ledger.Contexts (ScriptContext, - scriptCurrencySymbol) +import Plutus.V1.Ledger.Contexts (ScriptContext) +import Ledger.Contexts (scriptCurrencySymbol) + import qualified Plutus.V1.Ledger.Scripts as Scripts import Plutus.V1.Ledger.Value (AssetClass (..), TokenName (..), diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs index 7171142fb..2d1b01232 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs @@ -89,9 +89,9 @@ data InfoContractState = | Users (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) -infoEndpoints :: Aave -> Contract (ContractResponse Text InfoContractState) AaveInfoSchema Void () -infoEndpoints aave = forever $ - withContractResponse (Proxy @"fundsAt") FundsAt fundsAt +infoEndpoints :: Aave -> Promise (ContractResponse Text InfoContractState) AaveInfoSchema Void () +infoEndpoints aave = + (withContractResponse (Proxy @"fundsAt") FundsAt fundsAt `select` withContractResponse (Proxy @"poolFunds") PoolFunds (const $ poolFunds aave) `select` withContractResponse (Proxy @"reserves") Reserves (const $ reserves aave) - `select` withContractResponse (Proxy @"users") Users (const $ users aave) + `select` withContractResponse (Proxy @"users") Users (const $ users aave)) <> infoEndpoints aave diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs index 7a8dc406d..deccc0a37 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs @@ -93,7 +93,7 @@ start = start' $ do pkh <- pubKeyHash <$> ownPubKey fmap Currency.currencySymbol $ mapError (pack . show @Currency.CurrencyError) $ - Currency.forgeContract pkh [(Core.aaveProtocolName, 1)] + Currency.mintContract pkh [(Core.aaveProtocolName, 1)] start' :: Contract w s Text CurrencySymbol -> [CreateParams] -> Contract w s Text Aave start' getAaveToken params = do @@ -123,5 +123,5 @@ type AaveOwnerSchema = data OwnerContractState = Started Aave deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) -ownerEndpoints :: Contract (ContractResponse Text OwnerContractState) AaveOwnerSchema Void () -ownerEndpoints = forever $ withContractResponse (Proxy @"start") Started start +ownerEndpoints :: Promise (ContractResponse Text OwnerContractState) AaveOwnerSchema Void () +ownerEndpoints = withContractResponse (Proxy @"start") Started start <> ownerEndpoints diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs index 7bd81b162..7845efda2 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs @@ -332,7 +332,7 @@ revokeCollateral aave RevokeCollateralParams {..} = do userDatum = Core.UserCollateralFundsDatum rcpOnBehalfOf getUsersCollateral :: AssetClass -> TxOutTx -> Bool getUsersCollateral asset tx = ((> 0) . flip assetClassValueOf asset . txOutValue . txOutTxOut $ tx) && - (txOutDatumHash . txOutTxOut $ tx) == Just (datumHash . Datum . PlutusTx.toData $ userDatum asset) + (txOutDatumHash . txOutTxOut $ tx) == Just (datumHash . Datum . PlutusTx.toBuiltinData $ userDatum asset) getOwnPubKey :: Contract w s Text PubKeyHash getOwnPubKey = pubKeyHash <$> ownPubKey @@ -364,13 +364,13 @@ data UserContractState = Lens.makeClassyPrisms ''UserContractState -- TODO ? add repayWithCollateral -userEndpoints :: Aave -> Contract (ContractResponse Text UserContractState) AaveUserSchema Void () -userEndpoints aave = forever $ - withContractResponse (Proxy @"deposit") (const Deposited) (deposit aave) +userEndpoints :: Aave -> Promise (ContractResponse Text UserContractState) AaveUserSchema Void () +userEndpoints aave = + (withContractResponse (Proxy @"deposit") (const Deposited) (deposit aave) `select` withContractResponse (Proxy @"withdraw") (const Withdrawn) (withdraw aave) `select` withContractResponse (Proxy @"borrow") (const Borrowed) (borrow aave) `select` withContractResponse (Proxy @"repay") (const Repaid) (repay aave) `select` withContractResponse (Proxy @"provideCollateral") (const CollateralProvided) (provideCollateral aave) `select` withContractResponse (Proxy @"revokeCollateral") (const CollateralRevoked) (revokeCollateral aave) `select` withContractResponse (Proxy @"ownPubKey") GetPubKey (const getOwnPubKey) - `select` withContractResponse (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance) + `select` withContractResponse (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance)) <> userEndpoints aave diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs index 16f883817..0482bf4d2 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs @@ -28,7 +28,7 @@ import Ledger hiding (singleton) import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints import Ledger.Constraints.TxConstraints as Constraints -import Ledger.Typed.Scripts (MonetaryPolicy) +import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.Abstract.OutputValue (OutputValue (..)) import qualified Plutus.Abstract.TxUtils as TxUtils @@ -37,8 +37,8 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, Reserve (..)) import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken -import Plutus.V1.Ledger.Contexts (ScriptContext, - scriptCurrencySymbol) +import Plutus.V1.Ledger.Contexts (ScriptContext) +import Ledger.Contexts (scriptCurrencySymbol) import qualified Plutus.V1.Ledger.Scripts as Scripts import Plutus.V1.Ledger.Value (AssetClass (..), TokenName (..), @@ -53,8 +53,8 @@ import Prelude (Semigroup (..)) import qualified Prelude {-# INLINABLE validator #-} -validator :: ValidatorHash -> AssetClass -> TokenName -> ScriptContext -> Bool -validator aaveScript underlyingAsset aTokenName ctx = +validator :: ValidatorHash -> AssetClass -> TokenName -> BuiltinData -> ScriptContext -> Bool +validator aaveScript underlyingAsset aTokenName _ ctx = traceIfFalse "Aave tokens mint forbidden" $ amountMinted /= 0 && amountScriptAsset == amountMinted where txInfo :: TxInfo @@ -65,7 +65,7 @@ validator aaveScript underlyingAsset aTokenName ctx = amountAsset = flip assetClassValueOf underlyingAsset amountMinted :: Integer - amountMinted = assetClassValueOf (txInfoForge txInfo) aTokenCurrency + amountMinted = assetClassValueOf (txInfoMint txInfo) aTokenCurrency amountScriptAsset :: Integer amountScriptAsset = @@ -73,9 +73,9 @@ validator aaveScript underlyingAsset aTokenName ctx = inputValue = foldMap snd $ scriptInputsAt aaveScript txInfo in amountAsset outputValue - amountAsset inputValue -makeLiquidityPolicy :: ValidatorHash -> AssetClass -> MonetaryPolicy -makeLiquidityPolicy aaveScript asset = Scripts.mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| \s a t -> Scripts.wrapMonetaryPolicy $ validator s a t||]) +makeLiquidityPolicy :: ValidatorHash -> AssetClass -> MintingPolicy +makeLiquidityPolicy aaveScript asset = Scripts.mkMintingPolicyScript $ + $$(PlutusTx.compile [|| \s a t -> Scripts.wrapMintingPolicy $ validator s a t||]) `PlutusTx.applyCode` PlutusTx.liftCode aaveScript `PlutusTx.applyCode` diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs index 895c5e09c..5c9df5ec1 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs @@ -147,7 +147,7 @@ checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) = reservesOutputDatum = reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - remainderDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo + remainderDatumHash = findDatumHash (Datum $ PlutusTx.toBuiltinData ReserveFundsDatum) txInfo remainderValue = (`findValueByDatumHash` scriptOutputs) <$> remainderDatumHash checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool @@ -181,7 +181,7 @@ checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = may reservesOutputDatum = reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - investmentDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo + investmentDatumHash = findDatumHash (Datum $ PlutusTx.toBuiltinData ReserveFundsDatum) txInfo investmentValue = (`findValueByDatumHash` scriptOutputs) <$> investmentDatumHash checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs index 4acdc6663..8f3071f4c 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs @@ -4,7 +4,7 @@ module Plutus.Contracts.Service.FungibleToken where -import Ledger.Typed.Scripts (MonetaryPolicy) +import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.V1.Ledger.Contexts (ScriptContext) import qualified Plutus.V1.Ledger.Scripts as Scripts @@ -13,11 +13,11 @@ import qualified PlutusTx import PlutusTx.Prelude {-# INLINABLE validator #-} -validator :: TokenName -> ScriptContext -> Bool -validator _ _ = True +validator :: TokenName -> BuiltinData -> ScriptContext -> Bool +validator _ _ _ = True -makeLiquidityPolicy :: TokenName -> MonetaryPolicy -makeLiquidityPolicy tokenName = Scripts.mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . validator ||]) +makeLiquidityPolicy :: TokenName -> MintingPolicy +makeLiquidityPolicy tokenName = Scripts.mkMintingPolicyScript $ + $$(PlutusTx.compile [|| Scripts.wrapMintingPolicy . validator ||]) `PlutusTx.applyCode` PlutusTx.liftCode tokenName diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs index 35026434f..96558c385 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs @@ -100,7 +100,7 @@ oracleValue :: TxOut -> (DatumHash -> Maybe Datum) -> Maybe Integer oracleValue o f = do dh <- txOutDatum o Datum d <- f dh - PlutusTx.fromData d + PlutusTx.fromBuiltinData d {-# INLINABLE findOracleValueInTxInputs #-} findOracleValueInTxInputs :: TxInfo -> (CurrencySymbol, PubKeyHash, Integer, AssetClass) -> Maybe Integer @@ -184,7 +184,7 @@ data OracleParams = OracleParams startOracle :: forall w s. OracleParams -> Contract w s Text Oracle startOracle op = do pkh <- pubKeyHash <$> Contract.ownPubKey - osc <- mapError (pack . Prelude.show) (forgeContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency) + osc <- mapError (pack . Prelude.show) (mintContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency) let cs = Currency.currencySymbol osc oracle = Oracle { oSymbol = cs @@ -208,7 +208,7 @@ updateOracle oracle x = do let lookups = Constraints.unspentOutputs (Map.singleton oref o) <> Constraints.typedValidatorLookups (oracleInst oracle) <> Constraints.otherScript (oracleValidator oracle) - tx = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Update) + tx = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Update) ledgerTx <- submitTxConstraintsWith @Oracling lookups tx awaitTxConfirmed $ txId ledgerTx logInfo @Prelude.String $ "updated oracle value to " ++ Prelude.show x @@ -238,8 +238,8 @@ useOracle (fromTuple -> oracle) = do Constraints.otherScript (oracleValidator oracle) <> Constraints.unspentOutputs unspent let val = (assetClassValue oracleCoin 1) <> lovelaceValueOf (oFee oracle) - let tx = Constraints.mustSpendScriptOutput oracleRef (Redeemer $ PlutusTx.toData Use) <> - Constraints.mustPayToOtherScript (validatorHash $ oracleValidator oracle) (Datum $ PlutusTx.toData oracleDatum) val + let tx = Constraints.mustSpendScriptOutput oracleRef (Redeemer $ PlutusTx.toBuiltinData Use) <> + Constraints.mustPayToOtherScript (validatorHash $ oracleValidator oracle) (Datum $ PlutusTx.toBuiltinData oracleDatum) val pure $ (lookups, tx) where oracleCoin = oracleAsset oracle @@ -253,7 +253,8 @@ runOracle op = do go oracle where go :: Oracle -> Contract (Last Oracle) OracleSchema Text a - go oracle = do - x <- endpoint @"update" - updateOracle oracle x - go oracle + go oracle = + awaitPromise $ endpoint @"update" $ \x -> do + updateOracle oracle x + go oracle + \ No newline at end of file diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 868619e75..60ade2678 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -62,13 +62,13 @@ import Plutus.PAB.Simulator (Simulation, import qualified Plutus.PAB.Simulator as Simulator import Plutus.PAB.Types (PABError (..)) import qualified Plutus.PAB.Webserver.Server as PAB.Server -import Plutus.V1.Ledger.Crypto (getPubKeyHash, - pubKeyHash) +import Plutus.V1.Ledger.Crypto (getPubKeyHash) +import Ledger.Crypto (pubKeyHash) import Prelude hiding (init) import Wallet.Emulator.Types (Wallet (..), walletPubKey) import Wallet.Types (ContractInstanceId) - +import Data.Default (Default (def)) ownerWallet :: Wallet ownerWallet = Wallet 1 @@ -90,12 +90,12 @@ distributeFunds wallets assets = do ownPK <- pubKeyHash <$> ownPubKey let testCurrenciesValue = mconcat $ fmap (`assetClassValue` 1000) assets policyLookups = mconcat $ - fmap (Constraints.monetaryPolicy . FungibleToken.makeLiquidityPolicy . Prelude.snd . unAssetClass) assets + fmap (Constraints.mintingPolicy . FungibleToken.makeLiquidityPolicy . Prelude.snd . unAssetClass) assets adaValue = lovelaceValueOf amount forM_ wallets $ \w -> do let pkh = pubKeyHash $ walletPubKey w lookups = policyLookups - tx = mustForgeValue testCurrenciesValue <> mustPayToPubKey pkh (adaValue <> testCurrenciesValue) + tx = mustMintValue testCurrenciesValue <> mustPayToPubKey pkh (adaValue <> testCurrenciesValue) when (pkh /= ownPK) $ do ledgerTx <- submitTxConstraintsWith @Scripts.Any lookups tx void $ awaitTxConfirmed $ txId ledgerTx @@ -265,30 +265,25 @@ data AaveContracts = instance Pretty AaveContracts where pretty = viaShow -handleAaveContract :: - ( Member (Error PABError) effs - , Member (LogMsg (PABMultiAgentMsg (Builtin AaveContracts))) effs - ) - => ContractEffect (Builtin AaveContracts) - ~> Eff effs -handleAaveContract = Builtin.handleBuiltin getSchema getContract where - getSchema = \case - AaveUser _ -> Builtin.endpointsToSchemas @Aave.AaveUserSchema - AaveInfo _ -> Builtin.endpointsToSchemas @Aave.AaveInfoSchema - AaveStart -> Builtin.endpointsToSchemas @Aave.AaveOwnerSchema - DistributeFunds _ _ -> Builtin.endpointsToSchemas @Empty - CreateOracles _ -> Builtin.endpointsToSchemas @Empty - getContract = \case - AaveInfo aave -> SomeBuiltin $ Aave.infoEndpoints aave - AaveUser aave -> SomeBuiltin $ Aave.userEndpoints aave - AaveStart -> SomeBuiltin Aave.ownerEndpoints - DistributeFunds wallets assets -> SomeBuiltin $ distributeFunds wallets assets - CreateOracles assets -> SomeBuiltin $ createOracles assets +instance Builtin.HasDefinitions AaveContracts where + getDefinitions = [AaveStart] -- TODO: not sure about contract definitions + getSchema = \case + AaveUser _ -> Builtin.endpointsToSchemas @Aave.AaveUserSchema + AaveInfo _ -> Builtin.endpointsToSchemas @Aave.AaveInfoSchema + AaveStart -> Builtin.endpointsToSchemas @Aave.AaveOwnerSchema + DistributeFunds _ _ -> Builtin.endpointsToSchemas @Empty + CreateOracles _ -> Builtin.endpointsToSchemas @Empty + getContract = \case + AaveInfo aave -> SomeBuiltin $ Aave.infoEndpoints aave + AaveUser aave -> SomeBuiltin $ Aave.userEndpoints aave + AaveStart -> SomeBuiltin Aave.ownerEndpoints + DistributeFunds wallets assets -> SomeBuiltin $ distributeFunds wallets assets + CreateOracles assets -> SomeBuiltin $ createOracles assets handlers :: SimulatorEffectHandlers (Builtin AaveContracts) handlers = - Simulator.mkSimulatorHandlers @(Builtin AaveContracts) [] - $ interpret handleAaveContract + Simulator.mkSimulatorHandlers def def + $ interpret (Builtin.contractHandler (Builtin.handleBuiltin @AaveContracts)) oneAdaInLovelace :: Integer oneAdaInLovelace = 1000000 diff --git a/MetaLamp/lending-pool/test/Fixtures/Init.hs b/MetaLamp/lending-pool/test/Fixtures/Init.hs index 7b66213a1..68f0a0bc8 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Init.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Init.hs @@ -56,7 +56,7 @@ startContract :: Contract () Aave.AaveOwnerSchema Text () startContract = void $ AaveMock.start startParams userContract :: Contract (ContractResponse Text Aave.UserContractState) Aave.AaveUserSchema Void () -userContract = void $ Aave.userEndpoints AaveMock.aave +userContract = void $ awaitPromise $ Aave.userEndpoints AaveMock.aave distributeTrace :: Trace.EmulatorTrace () distributeTrace = do diff --git a/MetaLamp/lending-pool/test/Fixtures/Symbol.hs b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs index f6737d7fc..246ba5fac 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Symbol.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs @@ -11,7 +11,7 @@ import Data.Text (Text) import Data.Void (Void) import qualified Ledger import qualified Ledger.Constraints as Constraints -import Ledger.Typed.Scripts (MonetaryPolicy) +import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import qualified Plutus.Abstract.TxUtils as TxUtils import Plutus.Contract @@ -22,12 +22,12 @@ import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName, import qualified PlutusTx {-# INLINABLE validator #-} -validator :: TokenName -> ScriptContext -> Bool -validator _ _ = True +validator :: TokenName -> PlutusTx.BuiltinData -> ScriptContext -> Bool +validator _ _ _ = True -makePolicy :: TokenName -> MonetaryPolicy -makePolicy tokenName = Scripts.mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . validator ||]) +makePolicy :: TokenName -> MintingPolicy +makePolicy tokenName = Scripts.mkMintingPolicyScript $ + $$(PlutusTx.compile [|| Scripts.wrapMintingPolicy . validator ||]) `PlutusTx.applyCode` PlutusTx.liftCode tokenName diff --git a/MetaLamp/lending-pool/test/Spec/Shared.hs b/MetaLamp/lending-pool/test/Spec/Shared.hs index 5de4c67ec..2b12a3c09 100644 --- a/MetaLamp/lending-pool/test/Spec/Shared.hs +++ b/MetaLamp/lending-pool/test/Spec/Shared.hs @@ -5,7 +5,6 @@ module Spec.Shared where import qualified Fixtures import Plutus.Contract.Test (TracePredicate) import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave -import Plutus.V1.Ledger.Crypto (PubKeyHash) import Plutus.V1.Ledger.Value (AssetClass) import qualified PlutusTx.AssocMap as AssocMap import qualified Utils.Data as Utils diff --git a/MetaLamp/lending-pool/test/Utils/Data.hs b/MetaLamp/lending-pool/test/Utils/Data.hs index 71c620c55..d174c7187 100644 --- a/MetaLamp/lending-pool/test/Utils/Data.hs +++ b/MetaLamp/lending-pool/test/Utils/Data.hs @@ -2,7 +2,8 @@ module Utils.Data where import Data.Function ((&)) import Plutus.Abstract.ContractResponse (ContractResponse (..)) -import Plutus.V1.Ledger.Crypto (PubKeyHash, pubKeyHash) +import Plutus.V1.Ledger.Crypto (PubKeyHash) +import Ledger.Crypto (pubKeyHash) import qualified PlutusTx.AssocMap as AssocMap import qualified PlutusTx.Prelude as PlutusTx import Wallet.Emulator.Wallet (Wallet, walletPubKey) diff --git a/MetaLamp/lending-pool/test/Utils/Trace.hs b/MetaLamp/lending-pool/test/Utils/Trace.hs index e7de24026..3efc68edb 100644 --- a/MetaLamp/lending-pool/test/Utils/Trace.hs +++ b/MetaLamp/lending-pool/test/Utils/Trace.hs @@ -23,7 +23,7 @@ import Plutus.Abstract.ContractResponse (ContractResponse (..)) import Plutus.Contract.Test (TracePredicate) import qualified Plutus.Trace.Emulator as Trace import Plutus.Trace.Emulator.Types (EmulatorRuntimeError (..)) -import PlutusTx (IsData, fromData) +import PlutusTx (FromData, fromBuiltinData) import qualified Wallet.Emulator.Folds as Folds import Wallet.Emulator.MultiAgent (EmulatorEvent) @@ -50,18 +50,18 @@ getState pick userHandle = do utxoAtAddress :: Monad m => Address -> (UtxoMap -> m c)-> L.FoldM m EmulatorEvent c utxoAtAddress address check = Folds.postMapM check (L.generalize $ Folds.utxoAtAddress address) -datumsAtAddress :: (IsData a, Show a) => Address -> ([a] -> Bool) -> TracePredicate +datumsAtAddress :: (FromData a, Show a) => Address -> ([a] -> Bool) -> TracePredicate datumsAtAddress address check = utxoAtAddress address $ \utxo -> do let datums = getDatums utxo result = check datums unless result $ tell @(Doc Void) (fromString $ "Datum check failed: " <> show datums) pure result -getDatums :: IsData a => UtxoMap -> [a] +getDatums :: (FromData a) => UtxoMap -> [a] getDatums = mapMaybe findDatum . Map.elems -findDatum :: PlutusTx.IsData a => Ledger.TxOutTx -> Maybe a +findDatum :: (PlutusTx.FromData a) => Ledger.TxOutTx -> Maybe a findDatum o = do hash <- Ledger.txOutDatumHash $ Ledger.txOutTxOut o (Ledger.Datum e) <- Map.lookup hash $ Ledger.txData $ Ledger.txOutTxTx o - PlutusTx.fromData e + PlutusTx.fromBuiltinData e From f5f99f4067ae977b75ecba35e19c1216d1d077c7 Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Wed, 15 Sep 2021 11:02:01 +0700 Subject: [PATCH 2/6] update client --- MetaLamp/lending-pool/README.md | 2 +- MetaLamp/lending-pool/client/README.md | 5 -- .../client/scripts/start-chrome.sh | 1 - MetaLamp/lending-pool/client/spago.dhall | 4 ++ MetaLamp/lending-pool/client/src/AppAff.purs | 6 +- .../client/src/Business/Aave.purs | 2 +- MetaLamp/lending-pool/client/src/Main.purs | 2 +- .../lending-pool/generate-purs/AaveTypes.hs | 2 - MetaLamp/lending-pool/generate-purs/Main.hs | 33 +--------- MetaLamp/lending-pool/plutus-starter.cabal | 39 +++++++++--- .../src/Ext/Plutus/PAB/Webserver/Server.hs | 60 +++++++++++++++++++ .../lending-pool/src/Plutus/PAB/Simulation.hs | 8 ++- 12 files changed, 108 insertions(+), 56 deletions(-) delete mode 100755 MetaLamp/lending-pool/client/scripts/start-chrome.sh create mode 100644 MetaLamp/lending-pool/src/Ext/Plutus/PAB/Webserver/Server.hs diff --git a/MetaLamp/lending-pool/README.md b/MetaLamp/lending-pool/README.md index 3d3d6db7e..34c6fe6b3 100644 --- a/MetaLamp/lending-pool/README.md +++ b/MetaLamp/lending-pool/README.md @@ -32,7 +32,7 @@ cabal build all cabal run pab ``` -This will then start up the server on port 8080. +This will then start up the server on port 9080. 4. To run test simulation do: diff --git a/MetaLamp/lending-pool/client/README.md b/MetaLamp/lending-pool/client/README.md index 4a9bbdb90..aff6ecbef 100644 --- a/MetaLamp/lending-pool/client/README.md +++ b/MetaLamp/lending-pool/client/README.md @@ -33,11 +33,6 @@ npm start ``` 5. Open browser to interact with the app at https://localhost:8009/. -CORS protection needs to be disabled. You can use this script to launch chromium (note that first you need to close chromium completely, otherwise security won't be disabled): - -``` -npm run start-chrome -``` ## Troubleshooting diff --git a/MetaLamp/lending-pool/client/scripts/start-chrome.sh b/MetaLamp/lending-pool/client/scripts/start-chrome.sh deleted file mode 100755 index 776df5378..000000000 --- a/MetaLamp/lending-pool/client/scripts/start-chrome.sh +++ /dev/null @@ -1 +0,0 @@ -chromium --disable-web-security --user-data-dir=/chrome-temp \ No newline at end of file diff --git a/MetaLamp/lending-pool/client/spago.dhall b/MetaLamp/lending-pool/client/spago.dhall index e7b989c66..aedb337cc 100644 --- a/MetaLamp/lending-pool/client/spago.dhall +++ b/MetaLamp/lending-pool/client/spago.dhall @@ -6,6 +6,7 @@ You can edit this file as you like. , dependencies = [ "aff" , "affjax" + , "aff-promise" , "argonaut-codecs" , "avar" , "bigints" @@ -27,6 +28,9 @@ You can edit this file as you like. , "undefinable" , "uuid" , "web-socket" + , "routing" + , "routing-duplex" + , "halogen-formless" ] , packages = ./packages.dhall , sources = diff --git a/MetaLamp/lending-pool/client/src/AppAff.purs b/MetaLamp/lending-pool/client/src/AppAff.purs index ed0fba455..5267ffe16 100644 --- a/MetaLamp/lending-pool/client/src/AppAff.purs +++ b/MetaLamp/lending-pool/client/src/AppAff.purs @@ -81,9 +81,9 @@ post path body = do runAjax $ ajax decode affReq instance contractAppM :: Contract AppM where - getContracts = get "/api/new/contract/instances" - getContractStatus (ContractId cid) = get $ "/api/new/contract/instance/" <> cid <> "/status" - callEndpoint (Endpoint endpoint) (ContractId cid) params = post ("/api/new/contract/instance/" <> cid <> "/endpoint/" <> endpoint) (string <<< encodeJSON $ params) + getContracts = get "/api/contract/instances" + getContractStatus (ContractId cid) = get $ "/api/contract/instance/" <> cid <> "/status" + callEndpoint (Endpoint endpoint) (ContractId cid) params = post ("/api/contract/instance/" <> cid <> "/endpoint/" <> endpoint) (string <<< encodeJSON $ params) instance pollContractAppM :: PollContract AppM where pollDelay = liftAff <<< delay <<< Milliseconds $ 1000.0 diff --git a/MetaLamp/lending-pool/client/src/Business/Aave.purs b/MetaLamp/lending-pool/client/src/Business/Aave.purs index 8b4c56cec..838052c90 100644 --- a/MetaLamp/lending-pool/client/src/Business/Aave.purs +++ b/MetaLamp/lending-pool/client/src/Business/Aave.purs @@ -48,7 +48,7 @@ getAaveResponseWith endpoint pick cid param = pollEndpoint getNext endpoint para (preview pick state) getAaveContractId :: forall a. Prism' AaveContracts a -> ContractInstanceClientState AaveContracts -> Maybe ContractId -getAaveContractId pick (ContractInstanceClientState { cicContract, cicDefintion }) = (const $ toContractIdParam cicContract) <$> (preview pick cicDefintion) +getAaveContractId pick (ContractInstanceClientState st) = (const $ toContractIdParam st.cicContract) <$> (preview pick st.cicDefinition) toContractIdParam :: ContractInstanceId -> ContractId toContractIdParam (ContractInstanceId { unContractInstanceId: JsonUUID uuid }) = ContractId <<< UUID.toString $ uuid diff --git a/MetaLamp/lending-pool/client/src/Main.purs b/MetaLamp/lending-pool/client/src/Main.purs index 1b3ce2ac2..4f6ce16ff 100644 --- a/MetaLamp/lending-pool/client/src/Main.purs +++ b/MetaLamp/lending-pool/client/src/Main.purs @@ -13,7 +13,7 @@ main :: Effect Unit main = runHalogenAff do let - rootComponent = H.hoist (runAppM { host: "localhost", port: 8080 }) App.component + rootComponent = H.hoist (runAppM { host: "localhost", port: 9080 }) App.component body <- awaitBody runUI rootComponent unit body diff --git a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs index 47cc56afd..140384ec9 100644 --- a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs +++ b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs @@ -37,7 +37,6 @@ import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave import qualified Plutus.Contracts.Service.Oracle as Oracle import Plutus.PAB.Simulation (AaveContracts (..)) -import Plutus.V1.Ledger.Value (AssetClass) ratioBridge :: BridgePart ratioBridge = do @@ -56,7 +55,6 @@ aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Oracle.Oracle) , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractResponse E A)) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.CreateParams) - , (order <*> (equal <*> (genericShow <*> mkSumType))) (Proxy @AssetClass) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserContractState) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.InfoContractState) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Reserve) diff --git a/MetaLamp/lending-pool/generate-purs/Main.hs b/MetaLamp/lending-pool/generate-purs/Main.hs index 276c0e45f..cbe20e2be 100644 --- a/MetaLamp/lending-pool/generate-purs/Main.hs +++ b/MetaLamp/lending-pool/generate-purs/Main.hs @@ -13,12 +13,6 @@ module Main where import AaveTypes (aaveTypes, ratioBridge) -import Cardano.Metadata.Types (AnnotatedSignature, - HashFunction, - Property, - PropertyKey, - Subject, - SubjectProperties) import Cardano.Wallet.Types (WalletInfo) import Control.Applicative ((<|>)) import Control.Lens (set, view, (&)) @@ -47,9 +41,7 @@ import qualified PSGenerator.Common import Plutus.Contract.Checkpoint (CheckpointKey, CheckpointStore, CheckpointStoreItem) -import Plutus.Contract.Effects (TxConfirmed) import Plutus.Contract.Resumable (Responses) -import Plutus.PAB.Effects.Contract.ContractExe (ContractExe) import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse) import qualified Plutus.PAB.Webserver.API as API import Plutus.PAB.Webserver.Types (ChainReport, @@ -85,21 +77,8 @@ myBridge = PSGenerator.Common.servantBridge <|> PSGenerator.Common.miscBridge <|> ratioBridge <|> - metadataBridge <|> defaultBridge --- Some of the metadata types have a datakind type parameter that --- PureScript won't support, so we must drop it. -metadataBridge :: BridgePart -metadataBridge = do - (typeName ^== "Property") - <|> (typeName ^== "SubjectProperties") - <|> (typeName ^== "AnnotatedSignature") - typeModule ^== "Cardano.Metadata.Types" - moduleName <- view (haskType . typeModule) - name <- view (haskType . typeName) - pure $ TypeInfo "plutus-pab" moduleName name [] - data MyBridge myBridgeProxy :: Proxy MyBridge @@ -114,8 +93,7 @@ myTypes = PSGenerator.Common.ledgerTypes <> PSGenerator.Common.playgroundTypes <> PSGenerator.Common.walletTypes <> - [ (equal <*> (genericShow <*> mkSumType)) (Proxy @ContractExe) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @(FullReport A)) + [ (equal <*> (genericShow <*> mkSumType)) (Proxy @(FullReport A)) , (equal <*> (genericShow <*> mkSumType)) (Proxy @ChainReport) , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractReport A)) , (equal <*> (genericShow <*> mkSumType)) @@ -123,7 +101,6 @@ myTypes = , (equal <*> (genericShow <*> mkSumType)) (Proxy @(PartiallyDecodedResponse A)) -- Contract request / response types - , (equal <*> (genericShow <*> mkSumType)) (Proxy @TxConfirmed) , (equal <*> (genericShow <*> mkSumType)) (Proxy @CheckpointStore) , (order <*> (genericShow <*> mkSumType)) (Proxy @CheckpointKey) , (equal <*> (genericShow <*> mkSumType)) (Proxy @(CheckpointStoreItem A)) @@ -133,14 +110,6 @@ myTypes = , (equal <*> (genericShow <*> mkSumType)) (Proxy @(LogMessage A)) , (equal <*> (genericShow <*> mkSumType)) (Proxy @LogLevel) - -- Metadata types - , (order <*> (genericShow <*> mkSumType)) (Proxy @Subject) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @(SubjectProperties A)) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @(Property A)) - , (order <*> (genericShow <*> mkSumType)) (Proxy @PropertyKey) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @HashFunction) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @(AnnotatedSignature A)) - -- * Web API types , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractActivationArgs A)) , (genericShow <*> mkSumType) (Proxy @(ContractInstanceClientState A)) diff --git a/MetaLamp/lending-pool/plutus-starter.cabal b/MetaLamp/lending-pool/plutus-starter.cabal index 4b036fca9..9abedda0c 100644 --- a/MetaLamp/lending-pool/plutus-starter.cabal +++ b/MetaLamp/lending-pool/plutus-starter.cabal @@ -21,9 +21,27 @@ maintainer: Your email -- category: -- extra-source-files: CHANGELOG.md +flag defer-plugin-errors + description: + Defer errors from the plugin, useful for things like Haddock that can't handle it. + default: False + manual: True + +common lang + default-language: Haskell2010 + ghc-options: + -Wall -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -rtsopts + -- See Plutus Tx readme + -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + if flag(defer-plugin-errors) + ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors + library + import: lang exposed-modules: - Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.OnChain.Core Plutus.Contracts.LendingPool.OnChain.Core.Script Plutus.Contracts.LendingPool.OnChain.Core.Validator Plutus.Contracts.LendingPool.OnChain.Core.Logic Plutus.Contracts.LendingPool.OnChain.AToken Plutus.Contracts.LendingPool.OffChain.AToken Plutus.Contracts.LendingPool.OffChain.Info Plutus.Contracts.LendingPool.OffChain.Owner Plutus.Contracts.LendingPool.OffChain.State Plutus.Contracts.LendingPool.OffChain.User Plutus.PAB.Simulation Ext.Plutus.Ledger.Value Ext.Plutus.Ledger.Contexts + Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.OnChain.Core Plutus.Contracts.LendingPool.OnChain.Core.Script Plutus.Contracts.LendingPool.OnChain.Core.Validator Plutus.Contracts.LendingPool.OnChain.Core.Logic Plutus.Contracts.LendingPool.OnChain.AToken Plutus.Contracts.LendingPool.OffChain.AToken Plutus.Contracts.LendingPool.OffChain.Info Plutus.Contracts.LendingPool.OffChain.Owner Plutus.Contracts.LendingPool.OffChain.State Plutus.Contracts.LendingPool.OffChain.User Ext.Plutus.PAB.Webserver.Server Plutus.PAB.Simulation Ext.Plutus.Ledger.Value Ext.Plutus.Ledger.Contexts build-depends: base >= 4.9 && < 5, aeson, @@ -35,6 +53,13 @@ library freer-extras, prettyprinter, lens, + semigroups, + cryptonite, + memory, + data-default, + servant-server, + wai-cors, + servant-options, -- Plutus: playground-common, plutus-contract, @@ -45,12 +70,9 @@ library plutus-use-cases, plutus-pab hs-source-dirs: src - default-language: Haskell2010 - ghc-options: - -- See Plutus Tx readme - -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas executable pab + import: lang main-is: Main.hs hs-source-dirs: pab ghc-options: @@ -60,6 +82,7 @@ executable pab plutus-starter executable pab-simulation + import: lang main-is: Main.hs hs-source-dirs: pab-simulation ghc-options: @@ -69,6 +92,7 @@ executable pab-simulation plutus-starter executable generate-purs + import: lang main-is: Main.hs hs-source-dirs: generate-purs other-modules: AaveTypes @@ -78,7 +102,7 @@ executable generate-purs base >= 4.9 && < 5, aeson, directory, - servant-purescript, + servant-purescript -any, filepath, servant-server, bytestring, @@ -96,9 +120,10 @@ executable generate-purs plutus-contract, plutus-use-cases, plutus-ledger, - plutus-tx + plutus-tx -any test-suite test + import: lang type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test diff --git a/MetaLamp/lending-pool/src/Ext/Plutus/PAB/Webserver/Server.hs b/MetaLamp/lending-pool/src/Ext/Plutus/PAB/Webserver/Server.hs new file mode 100644 index 000000000..01717b020 --- /dev/null +++ b/MetaLamp/lending-pool/src/Ext/Plutus/PAB/Webserver/Server.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Ext.Plutus.PAB.Webserver.Server where + +import Cardano.Wallet.Types (WalletInfo (..)) +import Control.Concurrent.Availability (Availability, + available, newToken) +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy +import Ledger.Crypto (pubKeyHash) +import qualified Network.Wai.Middleware.Cors as Cors +import qualified Network.Wai.Middleware.Servant.Options as Cors +import qualified Plutus.PAB.Effects.Contract as Contract +import Plutus.PAB.Simulator (Simulation) +import qualified Plutus.PAB.Simulator as Simulator +import Plutus.PAB.Webserver.API (API, WSAPI, + WalletProxy) +import qualified Plutus.PAB.Webserver.Server as PAB +import Servant (Application, + Handler (Handler), Raw, + ServerT, err500, + errBody, hoistServer, + serve, + serveDirectoryFileServer, + (:<|>) ((:<|>))) +import qualified Servant + +-- Note: this definition is only to provide options responses +-- WSAPI is websocket api which does not support options requests +type CombinedAPI t = + API (Contract.ContractDef t) Integer + +startServer :: forall t. + ( FromJSON (Contract.ContractDef t) + , ToJSON (Contract.ContractDef t) + , Contract.PABContract t + , Servant.MimeUnrender Servant.JSON (Contract.ContractDef t) + ) + => Simulation t (Simulation t ()) +startServer = do + availability <- newToken + let mkWalletInfo = do + (wllt, pk) <- Simulator.addWallet + pure $ WalletInfo{wiWallet = wllt, wiPubKey = pk, wiPubKeyHash = pubKeyHash pk} + snd <$> PAB.startServer' [Cors.cors (const $ Just policy), provideOptions] 9080 (Right mkWalletInfo) Nothing availability 30 + where + provideOptions = Cors.provideOptions (Proxy @(CombinedAPI t)) + policy = Cors.simpleCorsResourcePolicy + { Cors.corsRequestHeaders = [ "content-type" ] } diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 60ade2678..97af461d5 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -69,6 +69,8 @@ import Wallet.Emulator.Types (Wallet (..), walletPubKey) import Wallet.Types (ContractInstanceId) import Data.Default (Default (def)) +import qualified Ext.Plutus.PAB.Webserver.Server as Ext.Plutus.PAB + ownerWallet :: Wallet ownerWallet = Wallet 1 @@ -148,10 +150,10 @@ activateContracts = do runLendingPool :: IO () runLendingPool = void $ Simulator.runSimulationWith handlers $ do - Simulator.logString @(Builtin AaveContracts) "Starting Aave PAB webserver on port 8080. Press enter to exit." - shutdown <- PAB.Server.startServerDebug + Simulator.logString @(Builtin AaveContracts) "Starting Aave PAB webserver on port 9080. Press enter to exit." + shutdown <- Ext.Plutus.PAB.startServer _ <- activateContracts - Simulator.logString @(Builtin AaveContracts) "Aave PAB webserver started on port 8080. Initialization complete. Press enter to exit." + Simulator.logString @(Builtin AaveContracts) "Aave PAB webserver started on port 9080. Initialization complete. Press enter to exit." _ <- liftIO getLine shutdown From e08682babd9be28736c4d35f50d91b6dabc27a6f Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Wed, 15 Sep 2021 11:03:19 +0700 Subject: [PATCH 3/6] make fmt --- .../lending-pool/src/Plutus/Abstract/ContractResponse.hs | 2 +- MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs | 2 +- .../src/Plutus/Contracts/LendingPool/OffChain/AToken.hs | 2 +- .../src/Plutus/Contracts/LendingPool/OffChain/Info.hs | 2 +- .../src/Plutus/Contracts/LendingPool/OffChain/User.hs | 2 +- .../src/Plutus/Contracts/LendingPool/OnChain/AToken.hs | 2 +- .../lending-pool/src/Plutus/Contracts/Service/Oracle.hs | 2 +- MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs | 6 +++--- 8 files changed, 10 insertions(+), 10 deletions(-) diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs index 68965e8eb..f2034134e 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs @@ -3,13 +3,13 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} module Plutus.Abstract.ContractResponse where diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs index 353ff5aae..f15481655 100644 --- a/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs @@ -41,7 +41,7 @@ import qualified Prelude type TxPair a = (Constraints.ScriptLookups a, Constraints.TxConstraints (RedeemerType a) (DatumType a)) type IsScriptData a = ( - PlutusTx.FromData (RedeemerType a), PlutusTx.ToData (RedeemerType a), + PlutusTx.FromData (RedeemerType a), PlutusTx.ToData (RedeemerType a), PlutusTx.FromData (DatumType a), PlutusTx.ToData (DatumType a)) submitTxPair :: (AsContractError e, IsScriptData a) => diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs index 7b7a848ab..3de6e87a5 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs @@ -20,6 +20,7 @@ import Ledger hiding (singleton) import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints import Ledger.Constraints.TxConstraints as Constraints +import Ledger.Contexts (scriptCurrencySymbol) import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.Abstract.OutputValue (OutputValue (..)) @@ -31,7 +32,6 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken import Plutus.V1.Ledger.Contexts (ScriptContext) -import Ledger.Contexts (scriptCurrencySymbol) import qualified Plutus.V1.Ledger.Scripts as Scripts import Plutus.V1.Ledger.Value (AssetClass (..), diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs index 2d1b01232..4fdc07c3d 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs @@ -90,7 +90,7 @@ data InfoContractState = deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) infoEndpoints :: Aave -> Promise (ContractResponse Text InfoContractState) AaveInfoSchema Void () -infoEndpoints aave = +infoEndpoints aave = (withContractResponse (Proxy @"fundsAt") FundsAt fundsAt `select` withContractResponse (Proxy @"poolFunds") PoolFunds (const $ poolFunds aave) `select` withContractResponse (Proxy @"reserves") Reserves (const $ reserves aave) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs index 7845efda2..fbc5e60dd 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs @@ -365,7 +365,7 @@ Lens.makeClassyPrisms ''UserContractState -- TODO ? add repayWithCollateral userEndpoints :: Aave -> Promise (ContractResponse Text UserContractState) AaveUserSchema Void () -userEndpoints aave = +userEndpoints aave = (withContractResponse (Proxy @"deposit") (const Deposited) (deposit aave) `select` withContractResponse (Proxy @"withdraw") (const Withdrawn) (withdraw aave) `select` withContractResponse (Proxy @"borrow") (const Borrowed) (borrow aave) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs index 0482bf4d2..d199da77e 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs @@ -28,6 +28,7 @@ import Ledger hiding (singleton) import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints import Ledger.Constraints.TxConstraints as Constraints +import Ledger.Contexts (scriptCurrencySymbol) import Ledger.Typed.Scripts (MintingPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.Abstract.OutputValue (OutputValue (..)) @@ -38,7 +39,6 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken import Plutus.V1.Ledger.Contexts (ScriptContext) -import Ledger.Contexts (scriptCurrencySymbol) import qualified Plutus.V1.Ledger.Scripts as Scripts import Plutus.V1.Ledger.Value (AssetClass (..), TokenName (..), diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs index 96558c385..e40331979 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs @@ -257,4 +257,4 @@ runOracle op = do awaitPromise $ endpoint @"update" $ \x -> do updateOracle oracle x go oracle - \ No newline at end of file + diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 97af461d5..1625e64d8 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -26,12 +26,14 @@ import Data.Aeson (FromJSON, ToJSON, encode, fromJSON) import qualified Data.ByteString as BS +import Data.Default (Default (def)) import qualified Data.Map.Strict as Map import qualified Data.Monoid as Monoid import qualified Data.Semigroup as Semigroup import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty (..), viaShow) +import qualified Ext.Plutus.PAB.Webserver.Server as Ext.Plutus.PAB import GHC.Generics (Generic) import Ledger import Ledger.Ada (adaSymbol, @@ -40,6 +42,7 @@ import Ledger.Ada (adaSymbol, lovelaceValueOf) import Ledger.Constraints import qualified Ledger.Constraints.OffChain as Constraints +import Ledger.Crypto (pubKeyHash) import qualified Ledger.Typed.Scripts as Scripts import Ledger.Value as Value import Plutus.Abstract.ContractResponse (ContractResponse (..)) @@ -63,13 +66,10 @@ import qualified Plutus.PAB.Simulator as Simulator import Plutus.PAB.Types (PABError (..)) import qualified Plutus.PAB.Webserver.Server as PAB.Server import Plutus.V1.Ledger.Crypto (getPubKeyHash) -import Ledger.Crypto (pubKeyHash) import Prelude hiding (init) import Wallet.Emulator.Types (Wallet (..), walletPubKey) import Wallet.Types (ContractInstanceId) -import Data.Default (Default (def)) -import qualified Ext.Plutus.PAB.Webserver.Server as Ext.Plutus.PAB ownerWallet :: Wallet ownerWallet = Wallet 1 From a1c067e4f3c36578aec5e0b7eb770d10edbaedbe Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Wed, 15 Sep 2021 15:32:32 +0700 Subject: [PATCH 4/6] remove mogus mock currency --- .../lending-pool/src/Plutus/PAB/Simulation.hs | 2 +- MetaLamp/lending-pool/test/Fixtures/Asset.hs | 10 +++++----- MetaLamp/lending-pool/test/Spec/Borrow.hs | 10 +++++----- MetaLamp/lending-pool/test/Spec/Deposit.hs | 10 +++++----- .../test/Spec/ProvideCollateral.hs | 12 +++++------ MetaLamp/lending-pool/test/Spec/Repay.hs | 10 +++++----- .../test/Spec/RevokeCollateral.hs | 14 ++++++------- MetaLamp/lending-pool/test/Spec/Withdraw.hs | 20 +++++++++---------- 8 files changed, 44 insertions(+), 44 deletions(-) diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 1625e64d8..a5316067b 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -78,7 +78,7 @@ userWallets :: [Wallet] userWallets = [Wallet i | i <- [2 .. 4]] testAssets :: [AssetClass] -testAssets = fmap toAsset ["MOGUS", "USD"] +testAssets = fmap toAsset ["EURO", "USD"] toAsset :: TokenName -> AssetClass toAsset tokenName = diff --git a/MetaLamp/lending-pool/test/Fixtures/Asset.hs b/MetaLamp/lending-pool/test/Fixtures/Asset.hs index 032e909cd..b7b37c369 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Asset.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Asset.hs @@ -7,17 +7,17 @@ import qualified Plutus.Contracts.LendingPool.OnChain.AToken as AToken import Plutus.PAB.Simulation (toAsset) import Plutus.V1.Ledger.Value (AssetClass) -mogus :: AssetClass -mogus = toAsset "MOGUS" +euro :: AssetClass +euro = toAsset "EURO" usd :: AssetClass usd = toAsset "USD" defaultAssets :: [AssetClass] -defaultAssets = [mogus, usd] +defaultAssets = [euro, usd] -amogus :: AssetClass -amogus = AToken.makeAToken AaveMock.aaveHash mogus +aeuro :: AssetClass +aeuro = AToken.makeAToken AaveMock.aaveHash euro ausd :: AssetClass ausd = AToken.makeAToken AaveMock.aaveHash usd diff --git a/MetaLamp/lending-pool/test/Spec/Borrow.hs b/MetaLamp/lending-pool/test/Spec/Borrow.hs index 9f5cea74b..5e2d46f6b 100644 --- a/MetaLamp/lending-pool/test/Spec/Borrow.hs +++ b/MetaLamp/lending-pool/test/Spec/Borrow.hs @@ -33,9 +33,9 @@ tests = testGroup "borrow" [ walletFundsChange Fixtures.borrowerWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.usd 50) + assetClassValue Fixtures.euro (negate 100) <> assetClassValue Fixtures.usd 50) .&&. Shared.reservesChange ( - Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus + Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro . Utils.modifyAt (over Aave._rAmount (subtract 50 . (+100))) Fixtures.usd $ Fixtures.initialReserves) .&&. Shared.userConfigsChange ( @@ -44,7 +44,7 @@ tests = testGroup "borrow" [ (Aave.UserConfig { Aave.ucDebt = 50, Aave.ucCollateralizedInvestment = 0 }) . AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.borrowerWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.borrowerWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) . AssocMap.insert @@ -57,8 +57,8 @@ tests = testGroup "borrow" [ handles <- Fixtures.defaultTrace deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 - deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 - provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.euro 100 + provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.euro 100 borrow (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 50, checkPredicate "Should fail if user's collateral is insufficient" diff --git a/MetaLamp/lending-pool/test/Spec/Deposit.hs b/MetaLamp/lending-pool/test/Spec/Deposit.hs index d6bce9936..7069e18c5 100644 --- a/MetaLamp/lending-pool/test/Spec/Deposit.hs +++ b/MetaLamp/lending-pool/test/Spec/Deposit.hs @@ -26,19 +26,19 @@ tests = testGroup "deposit" [ (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus 100) - .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + assetClassValue Fixtures.euro (negate 100) <> assetClassValue Fixtures.aeuro 100) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro Fixtures.initialReserves) .&&. Shared.userConfigsChange ( AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.lenderWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) $ Fixtures.initialUsers ) ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100, + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100, checkPredicate "Should fail if user's wallet balance is insufficient" (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds @@ -48,7 +48,7 @@ tests = testGroup "deposit" [ ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 10000 + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 10000 ] deposit :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () diff --git a/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs index d19aaf695..444963c59 100644 --- a/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs +++ b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs @@ -27,18 +27,18 @@ tests = testGroup "provideCollateral" [ (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100)) - .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + assetClassValue Fixtures.euro (negate 100)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro Fixtures.initialReserves) .&&. Shared.userConfigsChange (AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.lenderWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) Fixtures.initialUsers) ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 - provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100, + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100, checkPredicate "Should fail if user's aToken balance is insufficient" (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds @@ -48,7 +48,7 @@ tests = testGroup "provideCollateral" [ ) $ do handles <- Fixtures.defaultTrace - provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 ] provideCollateral :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () diff --git a/MetaLamp/lending-pool/test/Spec/Repay.hs b/MetaLamp/lending-pool/test/Spec/Repay.hs index 8a43d8804..995e7766d 100644 --- a/MetaLamp/lending-pool/test/Spec/Repay.hs +++ b/MetaLamp/lending-pool/test/Spec/Repay.hs @@ -34,9 +34,9 @@ tests = testGroup "repay" [ walletFundsChange Fixtures.borrowerWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.usd (50 - 25)) + assetClassValue Fixtures.euro (negate 100) <> assetClassValue Fixtures.usd (50 - 25)) .&&. Shared.reservesChange ( - Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus + Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro . Utils.modifyAt (over Aave._rAmount ((+25) . subtract 50 . (+100))) Fixtures.usd $ Fixtures.initialReserves) .&&. Shared.userConfigsChange ( @@ -45,7 +45,7 @@ tests = testGroup "repay" [ (Aave.UserConfig { Aave.ucDebt = 50 - 25, Aave.ucCollateralizedInvestment = 0 }) . AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.borrowerWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.borrowerWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) . AssocMap.insert @@ -58,8 +58,8 @@ tests = testGroup "repay" [ handles <- Fixtures.defaultTrace deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 - deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 - provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.euro 100 + provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.euro 100 borrow (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 50 repay (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 25 , diff --git a/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs index fd73eabb5..0b810d792 100644 --- a/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs +++ b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs @@ -28,19 +28,19 @@ tests = testGroup "revokeCollateral" [ (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus (100 - 100 + 50)) - .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + assetClassValue Fixtures.euro (negate 100) <> assetClassValue Fixtures.aeuro (100 - 100 + 50)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro Fixtures.initialReserves) .&&. Shared.userConfigsChange (AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.lenderWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 50 }) Fixtures.initialUsers) ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 - provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 - revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 50, + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 + revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 50, checkPredicate "Should fail if user's investment is insufficient" (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds @@ -50,7 +50,7 @@ tests = testGroup "revokeCollateral" [ ) $ do handles <- Fixtures.defaultTrace - revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 ] revokeCollateral :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () diff --git a/MetaLamp/lending-pool/test/Spec/Withdraw.hs b/MetaLamp/lending-pool/test/Spec/Withdraw.hs index acfbd225a..042e2f171 100644 --- a/MetaLamp/lending-pool/test/Spec/Withdraw.hs +++ b/MetaLamp/lending-pool/test/Spec/Withdraw.hs @@ -27,29 +27,29 @@ tests = testGroup "withdraw" [ (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100 + 50) <> assetClassValue Fixtures.amogus (100 - 50)) - .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (subtract 50 . (+100))) Fixtures.mogus Fixtures.initialReserves) + assetClassValue Fixtures.euro (negate 100 + 50) <> assetClassValue Fixtures.aeuro (100 - 50)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (subtract 50 . (+100))) Fixtures.euro Fixtures.initialReserves) .&&. Shared.userConfigsChange ( AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.lenderWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) $ Fixtures.initialUsers ) ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 - withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 50, + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 + withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 50, checkPredicate "Should fail if user's protocol balance is insufficient" (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> - assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus 100) - .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + assetClassValue Fixtures.euro (negate 100) <> assetClassValue Fixtures.aeuro 100) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.euro Fixtures.initialReserves) .&&. Shared.userConfigsChange ( AssocMap.insert - (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Fixtures.euro, Utils.getPubKey Fixtures.lenderWallet) (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) $ Fixtures.initialUsers ) @@ -57,8 +57,8 @@ tests = testGroup "withdraw" [ ) $ do handles <- Fixtures.defaultTrace - deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 - withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 200 + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 100 + withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.euro 200 ] withdraw :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () From 8243253a7a41b94223cf843e8c55a01f23746f47 Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Sat, 18 Sep 2021 10:17:55 +0700 Subject: [PATCH 5/6] remove unused packages --- MetaLamp/lending-pool/client/spago.dhall | 3 --- 1 file changed, 3 deletions(-) diff --git a/MetaLamp/lending-pool/client/spago.dhall b/MetaLamp/lending-pool/client/spago.dhall index aedb337cc..9df6e9667 100644 --- a/MetaLamp/lending-pool/client/spago.dhall +++ b/MetaLamp/lending-pool/client/spago.dhall @@ -28,9 +28,6 @@ You can edit this file as you like. , "undefinable" , "uuid" , "web-socket" - , "routing" - , "routing-duplex" - , "halogen-formless" ] , packages = ./packages.dhall , sources = From a5ad83c300964242769f87c96338a94218090df0 Mon Sep 17 00:00:00 2001 From: olgaklimenko Date: Sat, 18 Sep 2021 10:22:19 +0700 Subject: [PATCH 6/6] make fmt and update Makefile --- MetaLamp/lending-pool/Makefile | 5 ++-- .../client/src/Component/Contract.purs | 25 ++++++++++--------- MetaLamp/lending-pool/test/Utils/Data.hs | 2 +- 3 files changed, 17 insertions(+), 15 deletions(-) diff --git a/MetaLamp/lending-pool/Makefile b/MetaLamp/lending-pool/Makefile index 78eafd665..5f9b3b414 100644 --- a/MetaLamp/lending-pool/Makefile +++ b/MetaLamp/lending-pool/Makefile @@ -1,3 +1,4 @@ fmt: - find pab src -type f -name \*.hs -exec \ - stylish-haskell --inplace '{}' + + fix-stylish-haskell + fix-purty + diff --git a/MetaLamp/lending-pool/client/src/Component/Contract.purs b/MetaLamp/lending-pool/client/src/Component/Contract.purs index 9d2c778f6..cccb55445 100644 --- a/MetaLamp/lending-pool/client/src/Component/Contract.purs +++ b/MetaLamp/lending-pool/client/src/Component/Contract.purs @@ -217,7 +217,7 @@ component = (const <<< pure $ unit) revokeCollateral Nothing -> throwError "Asset name not found" - + render :: State -> H.ComponentHTML Action Slots m render state = HH.div_ @@ -227,17 +227,18 @@ component = Loading -> HH.div_ [] Failure e -> HH.h4_ [ HH.text e ] Success _ -> HH.div_ [] - , case state.submit of - Loading -> HH.div_ [ HH.text "Loading..." ] - _ -> HH.div_ - $ mapWithIndex - ( \index (Tuple title operation) -> - HH.h2_ - [ HH.text title - , HH.slot _amountForm index AmountForm.component (reservesToAmounts state.reserves) (Just <<< (OnSubmitAmount operation)) - ] - ) - [ Tuple "Deposit" SubmitDeposit, Tuple "Withdraw" SubmitWithdraw, Tuple "Borrow" SubmitBorrow, Tuple "Repay" SubmitRepay, Tuple "ProvideCollateral" SubmitProvideCollateral, Tuple "RevokeCollateral" SubmitRevokeCollateral ] + , case state.submit of + Loading -> HH.div_ [ HH.text "Loading..." ] + _ -> + HH.div_ + $ mapWithIndex + ( \index (Tuple title operation) -> + HH.h2_ + [ HH.text title + , HH.slot _amountForm index AmountForm.component (reservesToAmounts state.reserves) (Just <<< (OnSubmitAmount operation)) + ] + ) + [ Tuple "Deposit" SubmitDeposit, Tuple "Withdraw" SubmitWithdraw, Tuple "Borrow" SubmitBorrow, Tuple "Repay" SubmitRepay, Tuple "ProvideCollateral" SubmitProvideCollateral, Tuple "RevokeCollateral" SubmitRevokeCollateral ] ] reservesToAmounts :: Array { amount :: BigInteger, asset :: AssetClass } -> Array AmountForm.AmountInfo diff --git a/MetaLamp/lending-pool/test/Utils/Data.hs b/MetaLamp/lending-pool/test/Utils/Data.hs index d174c7187..60e33497d 100644 --- a/MetaLamp/lending-pool/test/Utils/Data.hs +++ b/MetaLamp/lending-pool/test/Utils/Data.hs @@ -1,9 +1,9 @@ module Utils.Data where import Data.Function ((&)) +import Ledger.Crypto (pubKeyHash) import Plutus.Abstract.ContractResponse (ContractResponse (..)) import Plutus.V1.Ledger.Crypto (PubKeyHash) -import Ledger.Crypto (pubKeyHash) import qualified PlutusTx.AssocMap as AssocMap import qualified PlutusTx.Prelude as PlutusTx import Wallet.Emulator.Wallet (Wallet, walletPubKey)