From 8885a264bebca6fa55b10258fed8b554bc88c010 Mon Sep 17 00:00:00 2001 From: Stanislav Zhdanovich Date: Fri, 24 Sep 2021 17:27:38 +0700 Subject: [PATCH 1/7] add remote data and contract resp --- MetaLamp/nft-marketplace/plutus-starter.cabal | 2 +- .../src/Plutus/Abstract/ContractResp.hs | 9 ++ .../src/Plutus/Abstract/RemoteData.hs | 92 +++++++++++++++++++ 3 files changed, 102 insertions(+), 1 deletion(-) create mode 100644 MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs create mode 100644 MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal index c0aaeb30f..01114e0b9 100644 --- a/MetaLamp/nft-marketplace/plutus-starter.cabal +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -41,7 +41,7 @@ common lang library import: lang exposed-modules: - Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Contracts.NftMarketplace.OffChain.Serialization Ext.Plutus.PAB.Webserver.Server Plutus.Contracts.NftMarketplace.OffChain.ID Plutus.Contracts.NftMarketplace.OnChain.Core.ID Plutus.Contracts.Services.Sale.Core Plutus.Contracts.NftMarketplace.OnChain.Core.NFT Ext.Plutus.Contracts.Auction Plutus.Contracts.Services.Sale Plutus.Contracts.Services.Sale.Endpoints Plutus.Contracts.Services.Sale.StateMachine Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Contracts.NftMarketplace.Endpoints Plutus.Contracts.NftMarketplace.OffChain.Owner Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine Plutus.PAB.Simulation + Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Abstract.RemoteData Plutus.Abstract.ContractResp Plutus.Contracts.NftMarketplace.OffChain.Serialization Ext.Plutus.PAB.Webserver.Server Plutus.Contracts.NftMarketplace.OffChain.ID Plutus.Contracts.NftMarketplace.OnChain.Core.ID Plutus.Contracts.Services.Sale.Core Plutus.Contracts.NftMarketplace.OnChain.Core.NFT Ext.Plutus.Contracts.Auction Plutus.Contracts.Services.Sale Plutus.Contracts.Services.Sale.Endpoints Plutus.Contracts.Services.Sale.StateMachine Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Contracts.NftMarketplace.Endpoints Plutus.Contracts.NftMarketplace.OffChain.Owner Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine Plutus.PAB.Simulation build-depends: base >= 4.9 && < 5, aeson, diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs new file mode 100644 index 000000000..c80ef6b70 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs @@ -0,0 +1,9 @@ +module Plutus.Abstract.ContractResp where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Plutus.Abstract.RemoteData (RemoteData) + +newtype ContractResp a = ContractResp + { getContractResponses :: Map.Map String (RemoteData Text a) + } diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs new file mode 100644 index 000000000..f82cc1dbc --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Plutus.Abstract.RemoteData where + +import qualified Control.Lens as Lens +import qualified Control.Lens.Extras as Lens +import qualified Data.Aeson as J +import GHC.Generics (Generic) +import Prelude hiding (maybe) + +-- | A datatype representing fetched data. +-- | +-- | If you find yourself continually using `Maybe (Either e a)` to +-- | represent data loaded from an external source, or you have a +-- | habit of shuffling errors away to where they can be quietly +-- | ignored, consider using this. It makes it easier to represent the +-- | real state of a remote data fetch and handle it properly. +-- | +-- | For more on the motivation, take a look at the blog post +-- | [How Elm Slays A UI Antipattern](http://blog.jenkster.com/2016/06/how-elm-slays-a-ui-antipattern.html). +-- | This is a port of that original Elm module. +data RemoteData e a + = NotAsked + | Loading + | Failure e + | Success a + deriving stock (Generic, Eq, Functor, Show, Foldable, Traversable) + deriving anyclass (J.FromJSON, J.ToJSON) +-- TODO implement Applicative Monad Bifunctor MonadThrow MonadError Bifoldable Bitraversable + +Lens.makeClassyPrisms ''RemoteData + +------------------------------------------------------------ + +-- | Convert a `RemoteData` to a `Maybe`. +toMaybe :: forall e a. RemoteData e a -> Maybe a +toMaybe (Success value) = Just value +toMaybe _ = Nothing + +-- | Convert a `Maybe` to `RemoteData`. +fromMaybe :: forall e a. Maybe a -> RemoteData e a +fromMaybe Nothing = NotAsked +fromMaybe (Just value) = Success value + +-- | Convert an `Either` to `RemoteData` +fromEither :: forall e a. Either e a -> RemoteData e a +fromEither (Left err) = Failure err +fromEither (Right value) = Success value + +-- | Takes a default value, a function, and a `RemoteData` value. If +-- | the data is `Success`, apply the function to the value, otherwise +-- | return the default. +-- | +-- | See also `withDefault`. +maybe :: forall e a b. b -> (a -> b) -> RemoteData e a -> b +maybe default' f (Success value) = f value +maybe default' f _ = default' + +-- | If the `RemoteData` has been successfully loaded, return that, +-- | otherwise return a default value. +withDefault :: forall e a. a -> RemoteData e a -> a +withDefault default' = maybe default' id + +------------------------------------------------------------ + +-- | Simple predicate. +isNotAsked :: forall e a. RemoteData e a -> Bool +isNotAsked = Lens.is _NotAsked + +-- | Simple predicate. +isLoading :: forall e a. RemoteData e a -> Bool +isLoading = Lens.is _Loading + +-- | Simple predicate. +isFailure :: forall e a. RemoteData e a -> Bool +isFailure = Lens.is _Failure + +-- | Simple predicate. +isSuccess :: forall e a. RemoteData e a -> Bool +isSuccess = Lens.is _Success From ba7586937a92819173362444959277f4873bc16a Mon Sep 17 00:00:00 2001 From: stanislav-az Date: Sat, 25 Sep 2021 15:17:29 +0700 Subject: [PATCH 2/7] add monoid for remote data --- MetaLamp/nft-marketplace/plutus-starter.cabal | 3 +- .../src/Plutus/Abstract/RemoteData.hs | 8 +++++ .../test/Abstract/RemoteDataSpec.hs | 29 +++++++++++++++++++ MetaLamp/nft-marketplace/test/Main.hs | 18 +++++++----- 4 files changed, 49 insertions(+), 9 deletions(-) create mode 100644 MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal index 01114e0b9..08f6a691a 100644 --- a/MetaLamp/nft-marketplace/plutus-starter.cabal +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -116,7 +116,7 @@ test-suite test main-is: Main.hs hs-source-dirs: test other-modules: - Marketplace.Spec.Start Utils.Data Marketplace.Spec.Auction Marketplace.Fixtures.NFT Marketplace.Spec.Bundles Marketplace.Spec.Sale Utils.Trace Utils Marketplace.Fixtures.Wallet Marketplace.Fixtures Marketplace.Fixtures.CheckOptions Marketplace.Fixtures.Script Marketplace.Spec.CreateNft + Marketplace.Spec.Start Abstract.RemoteDataSpec Utils.Data Marketplace.Spec.Auction Marketplace.Fixtures.NFT Marketplace.Spec.Bundles Marketplace.Spec.Sale Utils.Trace Utils Marketplace.Fixtures.Wallet Marketplace.Fixtures Marketplace.Fixtures.CheckOptions Marketplace.Fixtures.Script Marketplace.Spec.CreateNft build-depends: plutus-core -any, plutus-tx -any, @@ -144,6 +144,7 @@ test-suite test mtl -any, row-types -any, QuickCheck -any, + quickcheck-properties -any, freer-simple -any, foldl -any, streaming -any diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs index f82cc1dbc..2279fbb98 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs @@ -42,6 +42,14 @@ data RemoteData e a Lens.makeClassyPrisms ''RemoteData +instance Semigroup (RemoteData e a) where + NotAsked <> x = x + x <> NotAsked = x + x <> y = y + +instance Monoid (RemoteData e a) where + mempty = NotAsked + ------------------------------------------------------------ -- | Convert a `RemoteData` to a `Maybe`. diff --git a/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs new file mode 100644 index 000000000..9c4216623 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Abstract.RemoteDataSpec + ( tests + ) where + +import Plutus.Abstract.RemoteData (RemoteData (..)) +import qualified Test.QuickCheck.Property.Common as Q +import qualified Test.QuickCheck.Property.Monoid as Q +import Test.Tasty +import qualified Test.Tasty.QuickCheck as Q + +-- warning: Orphan instance +instance (Q.Arbitrary e, Q.Arbitrary a) => Q.Arbitrary (RemoteData e a) where + arbitrary = do + err <- Q.arbitrary + res <- Q.arbitrary + Q.elements [ NotAsked + , Loading + , Failure err + , Success res] + +tests :: TestTree +tests = + Q.testProperty "RemoteData Monoid instance" $ + Q.eq $ Q.prop_Monoid (Q.T :: Q.T (RemoteData String Int)) diff --git a/MetaLamp/nft-marketplace/test/Main.hs b/MetaLamp/nft-marketplace/test/Main.hs index dc152dd95..a35d2f644 100644 --- a/MetaLamp/nft-marketplace/test/Main.hs +++ b/MetaLamp/nft-marketplace/test/Main.hs @@ -1,7 +1,8 @@ module Main - ( main - ) where + ( main + ) where +import qualified Abstract.RemoteDataSpec as RemoteData import qualified Marketplace.Spec.Auction as Auction import qualified Marketplace.Spec.Bundles as Bundles import qualified Marketplace.Spec.CreateNft as CreateNft @@ -13,10 +14,11 @@ main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "NFT Marketplace" - [ Start.tests - , CreateNft.tests - , Bundles.tests - , Sale.tests - , Auction.tests +tests = + testGroup + "All tests" + [ testGroup + "NFT Marketplace" + [Start.tests, CreateNft.tests, Bundles.tests, Sale.tests, Auction.tests] + , testGroup "Abstract" [RemoteData.tests] ] From 9b47d3c514f7e41e33e98614263257a7280b45de Mon Sep 17 00:00:00 2001 From: stanislav-az Date: Sat, 25 Sep 2021 18:09:14 +0700 Subject: [PATCH 3/7] add contract resp monoid instance --- MetaLamp/nft-marketplace/plutus-starter.cabal | 4 ++- .../src/Plutus/Abstract/ContractResp.hs | 32 +++++++++++++++++-- .../src/Plutus/Abstract/RemoteData.hs | 10 ++++++ .../test/Abstract/ContractRespSpec.hs | 19 +++++++++++ .../test/Abstract/RemoteDataSpec.hs | 10 ------ MetaLamp/nft-marketplace/test/Main.hs | 3 +- 6 files changed, 63 insertions(+), 15 deletions(-) create mode 100644 MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal index 08f6a691a..a6ac78753 100644 --- a/MetaLamp/nft-marketplace/plutus-starter.cabal +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -59,6 +59,8 @@ library servant-server, wai-cors, servant-options, + QuickCheck, + quickcheck-instances, -- Plutus: playground-common, plutus-contract, @@ -116,7 +118,7 @@ test-suite test main-is: Main.hs hs-source-dirs: test other-modules: - Marketplace.Spec.Start Abstract.RemoteDataSpec Utils.Data Marketplace.Spec.Auction Marketplace.Fixtures.NFT Marketplace.Spec.Bundles Marketplace.Spec.Sale Utils.Trace Utils Marketplace.Fixtures.Wallet Marketplace.Fixtures Marketplace.Fixtures.CheckOptions Marketplace.Fixtures.Script Marketplace.Spec.CreateNft + Marketplace.Spec.Start Abstract.ContractRespSpec Abstract.RemoteDataSpec Utils.Data Marketplace.Spec.Auction Marketplace.Fixtures.NFT Marketplace.Spec.Bundles Marketplace.Spec.Sale Utils.Trace Utils Marketplace.Fixtures.Wallet Marketplace.Fixtures Marketplace.Fixtures.CheckOptions Marketplace.Fixtures.Script Marketplace.Spec.CreateNft build-depends: plutus-core -any, plutus-tx -any, diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs index c80ef6b70..8a616ce5b 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs @@ -1,9 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} + module Plutus.Abstract.ContractResp where +import qualified Data.Aeson as J import qualified Data.Map.Strict as Map import Data.Text (Text) +import GHC.Generics (Generic) import Plutus.Abstract.RemoteData (RemoteData) +import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck.Instances as Q + +newtype ContractResp a = + ContractResp + { getContractResponses :: Map.Map String (RemoteData Text a) + } + deriving (Eq, Show, Generic) + deriving newtype (J.ToJSON, J.FromJSON, Q.Arbitrary) + +instance Semigroup (ContractResp a) where + (ContractResp x) <> (ContractResp y) = ContractResp $ Map.unionWith (<>) x y -newtype ContractResp a = ContractResp - { getContractResponses :: Map.Map String (RemoteData Text a) - } +instance Monoid (ContractResp a) where + mempty = ContractResp mempty diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs index 2279fbb98..9a15d5f62 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs @@ -19,6 +19,7 @@ import qualified Control.Lens.Extras as Lens import qualified Data.Aeson as J import GHC.Generics (Generic) import Prelude hiding (maybe) +import qualified Test.QuickCheck as Q -- | A datatype representing fetched data. -- | @@ -50,6 +51,15 @@ instance Semigroup (RemoteData e a) where instance Monoid (RemoteData e a) where mempty = NotAsked +instance (Q.Arbitrary e, Q.Arbitrary a) => Q.Arbitrary (RemoteData e a) where + arbitrary = do + err <- Q.arbitrary + res <- Q.arbitrary + Q.elements [ NotAsked + , Loading + , Failure err + , Success res] + ------------------------------------------------------------ -- | Convert a `RemoteData` to a `Maybe`. diff --git a/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs new file mode 100644 index 000000000..ac0dba769 --- /dev/null +++ b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Abstract.ContractRespSpec + ( tests + ) where + +import Plutus.Abstract.ContractResp (ContractResp (..)) +import qualified Test.QuickCheck.Property.Common as Q +import qualified Test.QuickCheck.Property.Monoid as Q +import Test.Tasty +import qualified Test.Tasty.QuickCheck as Q + +tests :: TestTree +tests = + Q.testProperty "ContractResp Monoid instance" $ + Q.eq $ Q.prop_Monoid (Q.T :: Q.T (ContractResp String)) diff --git a/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs index 9c4216623..8014a07db 100644 --- a/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs +++ b/MetaLamp/nft-marketplace/test/Abstract/RemoteDataSpec.hs @@ -13,16 +13,6 @@ import qualified Test.QuickCheck.Property.Monoid as Q import Test.Tasty import qualified Test.Tasty.QuickCheck as Q --- warning: Orphan instance -instance (Q.Arbitrary e, Q.Arbitrary a) => Q.Arbitrary (RemoteData e a) where - arbitrary = do - err <- Q.arbitrary - res <- Q.arbitrary - Q.elements [ NotAsked - , Loading - , Failure err - , Success res] - tests :: TestTree tests = Q.testProperty "RemoteData Monoid instance" $ diff --git a/MetaLamp/nft-marketplace/test/Main.hs b/MetaLamp/nft-marketplace/test/Main.hs index a35d2f644..56b18c902 100644 --- a/MetaLamp/nft-marketplace/test/Main.hs +++ b/MetaLamp/nft-marketplace/test/Main.hs @@ -3,6 +3,7 @@ module Main ) where import qualified Abstract.RemoteDataSpec as RemoteData +import qualified Abstract.ContractRespSpec as ContractResp import qualified Marketplace.Spec.Auction as Auction import qualified Marketplace.Spec.Bundles as Bundles import qualified Marketplace.Spec.CreateNft as CreateNft @@ -20,5 +21,5 @@ tests = [ testGroup "NFT Marketplace" [Start.tests, CreateNft.tests, Bundles.tests, Sale.tests, Auction.tests] - , testGroup "Abstract" [RemoteData.tests] + , testGroup "Abstract" [RemoteData.tests, ContractResp.tests] ] From 5ece6712ada2fdc098ce8447bf18c1125cda0f1c Mon Sep 17 00:00:00 2001 From: stanislav-az Date: Sat, 25 Sep 2021 19:17:06 +0700 Subject: [PATCH 4/7] wip use contract resp --- MetaLamp/nft-marketplace/plutus-starter.cabal | 3 +- .../src/Plutus/Abstract/ContractResp.hs | 35 -------- .../src/Plutus/Abstract/ContractResponse.hs | 79 +++++++++++------- .../src/Plutus/Abstract/RemoteData.hs | 2 +- .../src/Plutus/PAB/Simulation.hs | 81 ++++++++++--------- .../test/Abstract/ContractRespSpec.hs | 2 +- MetaLamp/nft-marketplace/test/Main.hs | 2 +- 7 files changed, 95 insertions(+), 109 deletions(-) delete mode 100644 MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal index a6ac78753..4a2642a8b 100644 --- a/MetaLamp/nft-marketplace/plutus-starter.cabal +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -41,7 +41,7 @@ common lang library import: lang exposed-modules: - Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Abstract.RemoteData Plutus.Abstract.ContractResp Plutus.Contracts.NftMarketplace.OffChain.Serialization Ext.Plutus.PAB.Webserver.Server Plutus.Contracts.NftMarketplace.OffChain.ID Plutus.Contracts.NftMarketplace.OnChain.Core.ID Plutus.Contracts.Services.Sale.Core Plutus.Contracts.NftMarketplace.OnChain.Core.NFT Ext.Plutus.Contracts.Auction Plutus.Contracts.Services.Sale Plutus.Contracts.Services.Sale.Endpoints Plutus.Contracts.Services.Sale.StateMachine Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Contracts.NftMarketplace.Endpoints Plutus.Contracts.NftMarketplace.OffChain.Owner Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine Plutus.PAB.Simulation + Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Abstract.RemoteData Plutus.Contracts.NftMarketplace.OffChain.Serialization Ext.Plutus.PAB.Webserver.Server Plutus.Contracts.NftMarketplace.OffChain.ID Plutus.Contracts.NftMarketplace.OnChain.Core.ID Plutus.Contracts.Services.Sale.Core Plutus.Contracts.NftMarketplace.OnChain.Core.NFT Ext.Plutus.Contracts.Auction Plutus.Contracts.Services.Sale Plutus.Contracts.Services.Sale.Endpoints Plutus.Contracts.Services.Sale.StateMachine Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Contracts.NftMarketplace.Endpoints Plutus.Contracts.NftMarketplace.OffChain.Owner Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine Plutus.PAB.Simulation build-depends: base >= 4.9 && < 5, aeson, @@ -60,7 +60,6 @@ library wai-cors, servant-options, QuickCheck, - quickcheck-instances, -- Plutus: playground-common, plutus-contract, diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs deleted file mode 100644 index 8a616ce5b..000000000 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResp.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Plutus.Abstract.ContractResp where - -import qualified Data.Aeson as J -import qualified Data.Map.Strict as Map -import Data.Text (Text) -import GHC.Generics (Generic) -import Plutus.Abstract.RemoteData (RemoteData) -import qualified Test.QuickCheck as Q -import qualified Test.QuickCheck.Instances as Q - -newtype ContractResp a = - ContractResp - { getContractResponses :: Map.Map String (RemoteData Text a) - } - deriving (Eq, Show, Generic) - deriving newtype (J.ToJSON, J.FromJSON, Q.Arbitrary) - -instance Semigroup (ContractResp a) where - (ContractResp x) <> (ContractResp y) = ContractResp $ Map.unionWith (<>) x y - -instance Monoid (ContractResp a) where - mempty = ContractResp mempty diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs index 8395d1ccb..e74f46f0b 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Plutus.Abstract.ContractResponse where import qualified Control.Lens as Lens import Control.Monad hiding (fmap) -import qualified Data.Map as Map +import qualified Data.Aeson as J +import qualified Data.Map.Strict as Map import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) import Data.Text (Text, pack) import qualified Data.Text as Text import Data.Void (Void) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownSymbol, symbolVal) import Ledger hiding (singleton) import Ledger.Constraints as Constraints import Ledger.Constraints.OnChain as Constraints @@ -30,6 +34,7 @@ import Ledger.Constraints.TxConstraints as Constraints import qualified Ledger.Scripts as Scripts import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.RemoteData (RemoteData (..)) import Plutus.Contract hiding (when) import Plutus.Contracts.Currency as Currency import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) @@ -43,20 +48,33 @@ import PlutusTx.Prelude hiding (Monoid (..), import Prelude (Monoid (..), Semigroup (..), show, subtract) import qualified Prelude +import qualified Test.QuickCheck as Q import Text.Printf (printf) -data ContractResponse e a = CrSuccess a | CrError e | CrPending - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) - -Lens.makeClassyPrisms ''ContractResponse +newtype ContractResponse e a = + ContractResponse + { getEndpointResponses :: Map.Map Prelude.String (RemoteData e a) + } + deriving (Prelude.Eq, Prelude.Show, Generic) + deriving newtype (J.ToJSON, J.FromJSON, Q.Arbitrary) instance Semigroup (ContractResponse e a) where - a <> b = b + (ContractResponse x) <> (ContractResponse y) = ContractResponse $ Map.unionWith (<>) x y instance Monoid (ContractResponse e a) where - mempty = CrPending - mappend = (<>) + mempty = ContractResponse mempty + +updateEndpointStatus :: forall a e proxy l. (KnownSymbol l) => proxy l -> RemoteData e a -> ContractResponse e a +updateEndpointStatus p status = ContractResponse $ Map.singleton label status + where + label :: Prelude.String + label = symbolVal p + +getEndpointStatus :: forall a e proxy l. (KnownSymbol l) => proxy l -> ContractResponse e a -> RemoteData e a +getEndpointStatus p (ContractResponse res) = fromMaybe NotAsked $ Map.lookup label res + where + label :: Prelude.String + label = symbolVal p withContractResponse :: forall l a p r s. (HasEndpoint l p s, FromJSON p) @@ -64,17 +82,20 @@ withContractResponse :: forall l a p r s. -> (a -> r) -> (p -> Contract (ContractResponse Text r) s Text a) -> Promise (ContractResponse Text r) s Void () -withContractResponse _ g c = do +withContractResponse ep g c = do handleEndpoint @l $ \case - Left err -> tell $ CrError err + Left err -> tellEndpointStatus ep $ Failure err Right p -> do - _ <- tell CrPending + _ <- tellEndpointStatus ep Loading e <- runError $ errorHandler `handleError` c p - tell $ case e of - Left err -> CrError err - Right a -> CrSuccess $ g a + tellEndpointStatus ep $ case e of + Left err -> Failure err + Right a -> Success $ g a errorHandler :: Text -> Contract w s Text b errorHandler e = do logInfo @Text ("Error submiting the transaction: " <> e) throwError e + +tellEndpointStatus :: forall a s e ce proxy l m. (KnownSymbol l) => proxy l -> RemoteData e a -> Contract (ContractResponse e a) s ce () +tellEndpointStatus p status = tell $ updateEndpointStatus p status diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs index 9a15d5f62..7934ae400 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs @@ -19,7 +19,7 @@ import qualified Control.Lens.Extras as Lens import qualified Data.Aeson as J import GHC.Generics (Generic) import Prelude hiding (maybe) -import qualified Test.QuickCheck as Q +import qualified Test.QuickCheck as Q -- | A datatype representing fetched data. -- | diff --git a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs index 2198791e2..9b7672906 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Plutus.PAB.Simulation where @@ -21,13 +22,11 @@ import Control.Monad.Freer (Eff, Member, import Control.Monad.Freer.Error (Error) import Control.Monad.Freer.Extras.Log (LogMsg) import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (FromJSON, - Result (..), - ToJSON, encode, - fromJSON) +import qualified Data.Aeson as J import Data.Default (Default (def)) import qualified Data.Map.Strict as Map import qualified Data.Monoid as Monoid +import Data.Proxy (Proxy (..)) import qualified Data.Semigroup as Semigroup import Data.Text (Text) import Data.Text.Prettyprint.Doc (Pretty (..), @@ -43,7 +42,9 @@ import Ledger.Constraints import qualified Ledger.Constraints.OffChain as Constraints import qualified Ledger.Typed.Scripts as Scripts import Ledger.Value as Value -import Plutus.Abstract.ContractResponse (ContractResponse (..)) +import Plutus.Abstract.ContractResponse (ContractResponse (..), + getEndpointStatus) +import Plutus.Abstract.RemoteData (RemoteData (..)) import Plutus.Contract hiding (when) import Plutus.Contracts.Currency as Currency import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace @@ -78,8 +79,8 @@ activateContracts :: Simulation (Builtin MarketplaceContracts) ContractIDs activateContracts = do cidStart <- Simulator.activateContract ownerWallet MarketplaceStart _ <- Simulator.callEndpointOnInstance cidStart "start" () - mp <- flip Simulator.waitForState cidStart $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.OwnerContractState)) of - Success (CrSuccess (Marketplace.Started mp)) -> Just mp + mp <- flip Simulator.waitForState cidStart $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.OwnerContractState)) of + J.Success (getEndpointStatus (Proxy @"start") -> Success (Marketplace.Started mp)) -> Just mp _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Marketplace instance created: " ++ show mp @@ -121,8 +122,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do cnpNftCategory = ["GIFs"], cnpRevealIssuer = False } - flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.NftCreated) -> Just () + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"createNft") -> Success Marketplace.NftCreated) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" @@ -132,8 +133,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do ospItemId = Marketplace.UserNftId catTokenIpfsCid, ospSalePrice = 44*oneAdaInLovelace } - sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.OpenedSale) -> Just () + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"openSale") -> Success Marketplace.OpenedSale) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" @@ -144,8 +145,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do Simulator.callEndpointOnInstance buyerCid "buyItem" Marketplace.CloseLotParams { clpItemId = Marketplace.UserNftId catTokenIpfsCid } - _ <- flip Simulator.waitForState buyerCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.NftBought) -> Just () + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"buyItem") -> Success Marketplace.NftBought) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful buyItem" @@ -158,8 +159,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do cnpNftCategory = ["Photos"], cnpRevealIssuer = True } - flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.NftCreated) -> Just () + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"createNft") -> Success Marketplace.NftCreated) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" @@ -169,8 +170,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do ospItemId = Marketplace.UserNftId photoTokenIpfsCid, ospSalePrice = 12*oneAdaInLovelace } - sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.OpenedSale) -> Just () + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"openSale") -> Success Marketplace.OpenedSale) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" @@ -179,8 +180,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do Marketplace.CloseLotParams { clpItemId = Marketplace.UserNftId photoTokenIpfsCid } - sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.ClosedSale) -> Just () + sale <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"closeSale") -> Success Marketplace.ClosedSale) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful closeSale" @@ -190,8 +191,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do } _ <- Simulator.callEndpointOnInstance userCid "startAnAuction" auction - _ <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.AuctionStarted) -> Just () + _ <- flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"startAnAuction") -> Success Marketplace.AuctionStarted) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Started An Auction" @@ -200,21 +201,21 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do boapItemId = Marketplace.UserNftId photoTokenIpfsCid, boapBid = fromInteger $ 15*oneAdaInLovelace } - _ <- flip Simulator.waitForState buyerCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.BidSubmitted) -> Just () + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"bidOnAuction") -> Success Marketplace.BidSubmitted) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful bidOnAuction" _ <- Simulator.callEndpointOnInstance cidInfo "getAuctionState" $ Marketplace.UserNftId photoTokenIpfsCid - s <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of - Success (CrSuccess (Marketplace.AuctionState s)) -> Just s + s <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.InfoContractState)) of + J.Success (getEndpointStatus (Proxy @"getAuctionState") -> Success (Marketplace.AuctionState s)) -> Just s _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Final auction state: " <> show s _ <- Simulator.callEndpointOnInstance buyerCid "completeAnAuction" $ Marketplace.CloseLotParams $ Marketplace.UserNftId photoTokenIpfsCid - _ <- flip Simulator.waitForState buyerCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.AuctionComplete) -> Just () + _ <- flip Simulator.waitForState buyerCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"completeAnAuction") -> Success Marketplace.AuctionComplete) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful holdAnAuction" @@ -226,8 +227,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do bupDescription = "Collection of visual media", bupCategory = ["User","Stan"] } - flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.Bundled) -> Just () + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"bundleUp") -> Success Marketplace.Bundled) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful bundleUp" @@ -236,32 +237,32 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do Marketplace.UnbundleParams { upIpfsCids = [photoTokenIpfsCid,catTokenIpfsCid] } - flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of - Success (CrSuccess Marketplace.Unbundled) -> Just () + flip Simulator.waitForState userCid $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.UserContractState)) of + J.Success (getEndpointStatus (Proxy @"unbundle") -> Success Marketplace.Unbundled) -> Just () _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful unbundle" _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" buyer - v <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of - Success (CrSuccess (Marketplace.FundsAt v)) -> Just v + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.InfoContractState)) of + J.Success (getEndpointStatus (Proxy @"fundsAt") -> Success (Marketplace.FundsAt v)) -> Just v _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Final buyer funds: " <> show v _ <- Simulator.callEndpointOnInstance cidInfo "marketplaceStore" () - marketplaceStore <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of - Success (CrSuccess (Marketplace.MarketplaceStore marketplaceStore)) -> Just marketplaceStore + marketplaceStore <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.InfoContractState)) of + J.Success (getEndpointStatus (Proxy @"marketplaceStore") -> Success (Marketplace.MarketplaceStore marketplaceStore)) -> Just marketplaceStore _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Final marketplaceStore: " <> show marketplaceStore _ <- Simulator.callEndpointOnInstance cidInfo "marketplaceFunds" () - v <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of - Success (CrSuccess (Marketplace.MarketplaceFunds v)) -> Just v + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.InfoContractState)) of + J.Success (getEndpointStatus (Proxy @"marketplaceFunds") -> Success (Marketplace.MarketplaceFunds v)) -> Just v _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Final marketplace funds: " <> show v _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" sender - v <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of - Success (CrSuccess (Marketplace.FundsAt v)) -> Just v + v <- flip Simulator.waitForState cidInfo $ \json -> case (J.fromJSON json :: J.Result (ContractResponse Text Marketplace.InfoContractState)) of + J.Success (getEndpointStatus (Proxy @"fundsAt") -> Success (Marketplace.FundsAt v)) -> Just v _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Final user funds: " <> show v @@ -273,7 +274,7 @@ data MarketplaceContracts = | MarketplaceInfo Marketplace.Marketplace | MarketplaceUser Marketplace.Marketplace deriving (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (J.FromJSON, J.ToJSON) instance Pretty MarketplaceContracts where pretty = viaShow diff --git a/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs index ac0dba769..4147e1f86 100644 --- a/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs +++ b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs @@ -7,7 +7,7 @@ module Abstract.ContractRespSpec ( tests ) where -import Plutus.Abstract.ContractResp (ContractResp (..)) +import Plutus.Abstract.ContractResp (ContractResp (..)) import qualified Test.QuickCheck.Property.Common as Q import qualified Test.QuickCheck.Property.Monoid as Q import Test.Tasty diff --git a/MetaLamp/nft-marketplace/test/Main.hs b/MetaLamp/nft-marketplace/test/Main.hs index 56b18c902..1426a6e92 100644 --- a/MetaLamp/nft-marketplace/test/Main.hs +++ b/MetaLamp/nft-marketplace/test/Main.hs @@ -2,8 +2,8 @@ module Main ( main ) where +import qualified Abstract.ContractRespSpec as ContractResp import qualified Abstract.RemoteDataSpec as RemoteData -import qualified Abstract.ContractRespSpec as ContractResp import qualified Marketplace.Spec.Auction as Auction import qualified Marketplace.Spec.Bundles as Bundles import qualified Marketplace.Spec.CreateNft as CreateNft From c9cb8f5fdc496d0a0d4602a90209556c90c926b5 Mon Sep 17 00:00:00 2001 From: Stanislav Zhdanovich Date: Thu, 30 Sep 2021 14:14:49 +0700 Subject: [PATCH 5/7] fix tests --- .../test/Abstract/ContractRespSpec.hs | 12 +++++------ .../test/Marketplace/Spec/Auction.hs | 20 +++++++++++-------- .../test/Marketplace/Spec/Bundles.hs | 12 +++++++---- .../test/Marketplace/Spec/Sale.hs | 16 +++++++++------ MetaLamp/nft-marketplace/test/Utils/Trace.hs | 16 +++++++++++---- 5 files changed, 48 insertions(+), 28 deletions(-) diff --git a/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs index 4147e1f86..939bf1efa 100644 --- a/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs +++ b/MetaLamp/nft-marketplace/test/Abstract/ContractRespSpec.hs @@ -7,13 +7,13 @@ module Abstract.ContractRespSpec ( tests ) where -import Plutus.Abstract.ContractResp (ContractResp (..)) -import qualified Test.QuickCheck.Property.Common as Q -import qualified Test.QuickCheck.Property.Monoid as Q +import Plutus.Abstract.ContractResponse (ContractResponse (..)) +import qualified Test.QuickCheck.Property.Common as Q +import qualified Test.QuickCheck.Property.Monoid as Q import Test.Tasty -import qualified Test.Tasty.QuickCheck as Q +import qualified Test.Tasty.QuickCheck as Q tests :: TestTree tests = - Q.testProperty "ContractResp Monoid instance" $ - Q.eq $ Q.prop_Monoid (Q.T :: Q.T (ContractResp String)) + Q.testProperty "ContractResponse Monoid instance" $ + Q.eq $ Q.prop_Monoid (Q.T :: Q.T (ContractResponse String String)) diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs index 8f74dc9bc..9601eb1c8 100644 --- a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Auction.hs @@ -12,6 +12,7 @@ import Control.Lens (_2, _Right, (&), import Control.Monad (void) import Data.Foldable (find) import Data.Maybe (isNothing) +import Data.Proxy import Data.Text (Text) import Data.Void (Void) import qualified Ext.Plutus.Contracts.Auction as Auction @@ -46,7 +47,7 @@ tests = checkPredicateOptions Fixtures.options "Should not put on auction if NFT does not exist" - errorCheckUser + errorCheckStart startAnAuctionTrace', checkPredicateOptions Fixtures.options @@ -56,7 +57,7 @@ tests = checkPredicateOptions Fixtures.options "Should not close auction if it was not started" - errorCheckUser + errorCheckComplete completeAnAuctionTrace', checkPredicateOptions Fixtures.options @@ -66,7 +67,7 @@ tests = checkPredicateOptions Fixtures.options "Should not bid if NFT is not on auction" - errorCheckBuyer + errorCheckBid bidOnAuctionTrace', checkPredicateOptions Fixtures.options @@ -85,7 +86,7 @@ tests = checkPredicateOptions Fixtures.options "Should not put on auction if bundle does not exist" - errorCheckUser + errorCheckStart startAnAuctionTraceB', checkPredicateOptions Fixtures.options @@ -234,11 +235,14 @@ buyOnAuctionValueCheck = where hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs -errorCheckUser :: TracePredicate -errorCheckUser = Utils.assertCrError (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) +errorCheckStart :: TracePredicate +errorCheckStart = Utils.assertCrError (Proxy @"startAnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) -errorCheckBuyer :: TracePredicate -errorCheckBuyer = Utils.assertCrError (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) +errorCheckComplete :: TracePredicate +errorCheckComplete = Utils.assertCrError (Proxy @"completeAnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckBid :: TracePredicate +errorCheckBid = Utils.assertCrError (Proxy @"bidOnAuction") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) -- \/\/\/ "NFT bundles" startAnAuctionParamsB :: Marketplace.StartAnAuctionParams diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs index 764bb45fb..a03f127ee 100644 --- a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Bundles.hs @@ -10,6 +10,7 @@ module Marketplace.Spec.Bundles import Control.Lens ((^.), (^?)) import Control.Monad (void) import Data.Maybe (isNothing) +import Data.Proxy import Data.Text (Text) import Data.Void (Void) import qualified Marketplace.Fixtures as Fixtures @@ -36,7 +37,7 @@ tests = checkPredicateOptions Fixtures.options "Should not create a bundle if NFTs are not minted" - errorCheck + errorCheckBundle bundleErrorTrace, checkPredicateOptions Fixtures.options @@ -46,7 +47,7 @@ tests = checkPredicateOptions Fixtures.options "Should not unbundle if bundle does not exist" - errorCheck + errorCheckUnbundle unbundleErrorTrace ] @@ -111,8 +112,11 @@ bundleDatumsCheck = maybe False Fixtures.hasPhotoTokenRecord (AssocMap.lookup Fixtures.photoTokenIpfsCidHash b) -errorCheck :: TracePredicate -errorCheck = Utils.assertCrError (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) +errorCheckBundle :: TracePredicate +errorCheckBundle = Utils.assertCrError (Proxy @"bundleUp") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckUnbundle :: TracePredicate +errorCheckUnbundle = Utils.assertCrError (Proxy @"unbundle") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) unbundleTrace :: Trace.EmulatorTrace () unbundleTrace = do diff --git a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs index 10b688fc5..a9e38a487 100644 --- a/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs +++ b/MetaLamp/nft-marketplace/test/Marketplace/Spec/Sale.hs @@ -12,6 +12,7 @@ import Control.Lens (_2, _Left, (&), import Control.Monad (void) import Data.Foldable (find) import Data.Maybe (isNothing) +import Data.Proxy import Data.Text (Text) import Data.Void (Void) import qualified Ledger.Value as V @@ -45,7 +46,7 @@ tests = checkPredicateOptions Fixtures.options "Should not put on sale if NFT does not exist" - errorCheckUser + errorCheckOpen openSaleTrace', checkPredicateOptions Fixtures.options @@ -55,7 +56,7 @@ tests = checkPredicateOptions Fixtures.options "Should not close sale if it was not started" - errorCheckUser + errorCheckClose closeSaleTrace', checkPredicateOptions Fixtures.options @@ -79,7 +80,7 @@ tests = checkPredicateOptions Fixtures.options "Should not put on sale if bundle does not exist" - errorCheckUser + errorCheckOpen openSaleTraceB', checkPredicateOptions Fixtures.options @@ -205,11 +206,14 @@ buyItemValueCheck = where hasNft v = (v ^. _2 & V.unTokenName) == Fixtures.catTokenIpfsCidBs -errorCheckUser :: TracePredicate -errorCheckUser = Utils.assertCrError (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) +errorCheckOpen :: TracePredicate +errorCheckOpen = Utils.assertCrError (Proxy @"openSale") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) + +errorCheckClose :: TracePredicate +errorCheckClose = Utils.assertCrError (Proxy @"closeSale") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.userWallet) errorCheckBuyer :: TracePredicate -errorCheckBuyer = Utils.assertCrError (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) +errorCheckBuyer = Utils.assertCrError (Proxy @"buyItem") (Marketplace.userEndpoints Fixtures.marketplace) (Trace.walletInstanceTag Fixtures.buyerWallet) -- \/\/\/ "NFT bundles" openSaleParamsB :: Marketplace.OpenSaleParams diff --git a/MetaLamp/nft-marketplace/test/Utils/Trace.hs b/MetaLamp/nft-marketplace/test/Utils/Trace.hs index bc0d7d8aa..39ca214f9 100644 --- a/MetaLamp/nft-marketplace/test/Utils/Trace.hs +++ b/MetaLamp/nft-marketplace/test/Utils/Trace.hs @@ -8,15 +8,23 @@ module Utils.Trace where import Control.Lens ((^?)) import Data.Maybe (isJust) -import Plutus.Abstract.ContractResponse (AsContractResponse (_CrError), - ContractResponse) +import GHC.TypeLits (KnownSymbol) +import Plutus.Abstract.ContractResponse (ContractResponse, + getEndpointStatus) +import qualified Plutus.Abstract.RemoteData as RD import qualified Plutus.Contract as C import Plutus.Contract.Test (TracePredicate, assertAccumState) import qualified Plutus.Trace.Emulator as Trace -assertCrError :: forall contract e r s err a. (Show r, Show e, C.IsContract contract) => +assertCrError :: forall contract e r s err a proxy l. (Show r, Show e, C.IsContract contract, KnownSymbol l) => + proxy l -> contract (ContractResponse e r) s err a -> Trace.ContractInstanceTag -> TracePredicate -assertCrError c tag = assertAccumState c tag (isJust . (^? _CrError)) "Expected contract error but there was none" +assertCrError p c tag = assertAccumState c tag isError "Expected contract error but there was none" + where + isError :: ContractResponse e r -> Bool + isError = RD.isFailure . getEndpointStatus p + + From dca45516ec338f5689c0d658cabef65677630821 Mon Sep 17 00:00:00 2001 From: Stanislav Zhdanovich Date: Thu, 30 Sep 2021 14:35:47 +0700 Subject: [PATCH 6/7] fix simulation --- MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs index 9b7672906..745d9a8d2 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs @@ -164,6 +164,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" + _ <- Simulator.waitNSlots 10 + _ <- Simulator.callEndpointOnInstance userCid "openSale" $ Marketplace.OpenSaleParams { @@ -175,6 +177,8 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" + _ <- Simulator.waitNSlots 10 + _ <- Simulator.callEndpointOnInstance userCid "closeSale" Marketplace.CloseLotParams { @@ -187,7 +191,7 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do let auction = Marketplace.StartAnAuctionParams { saapItemId = Marketplace.UserNftId photoTokenIpfsCid, - saapDuration = 80 * 1000 + saapDuration = 25 * 1000 } _ <- Simulator.callEndpointOnInstance userCid "startAnAuction" auction From 380ea5d018f44ec22d7c6009233c1d2eb1f73e1b Mon Sep 17 00:00:00 2001 From: Stanislav Zhdanovich Date: Thu, 30 Sep 2021 16:37:35 +0700 Subject: [PATCH 7/7] use contract resp in client --- .../client/src/Business/Marketplace.purs | 17 ++++++++++------- .../client/src/Capability/Contract.purs | 7 ++++--- MetaLamp/nft-marketplace/generate-purs/Main.hs | 3 +-- .../generate-purs/MarketplaceTypes.hs | 13 ++----------- .../src/Plutus/Abstract/ContractResponse.hs | 3 ++- 5 files changed, 19 insertions(+), 24 deletions(-) diff --git a/MetaLamp/nft-marketplace/client/src/Business/Marketplace.purs b/MetaLamp/nft-marketplace/client/src/Business/Marketplace.purs index b2082760d..f31eb52b1 100644 --- a/MetaLamp/nft-marketplace/client/src/Business/Marketplace.purs +++ b/MetaLamp/nft-marketplace/client/src/Business/Marketplace.purs @@ -1,22 +1,25 @@ module Business.Marketplace where import Prelude +import Utils.APIError import Capability.Contract (class Contract, ContractId(..), Endpoint, getContracts) import Capability.PollContract (class PollContract, LeftPoll(..), PollError, PollResponse, pollEndpoint) import Control.Monad.Except (runExcept, throwError, withExcept) import Data.Either (Either) import Data.Json.JsonUUID (JsonUUID(..)) import Data.Lens (Prism', preview) -import Data.Maybe (Maybe, maybe) +import Data.Map (lookup) +import Data.Maybe (Maybe(..), maybe) +import Data.Newtype (unwrap) import Data.RawJson (RawJson(..)) +import Data.UUID (toString) as UUID import Foreign.Generic (class Decode, class Encode, decodeJSON) import Plutus.Abstract.ContractResponse (ContractResponse(..)) +import Plutus.Abstract.RemoteData as PRD import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse(..)) import Plutus.PAB.Simulation (MarketplaceContracts) import Plutus.PAB.Webserver.Types (ContractInstanceClientState(..)) import Wallet.Types (ContractInstanceId(..)) -import Data.UUID (toString) as UUID -import Utils.APIError getMarketplaceContracts :: forall m. Contract m => m (Either APIError (Array (ContractInstanceClientState MarketplaceContracts))) getMarketplaceContracts = getContracts @@ -39,14 +42,14 @@ getMarketplaceResponseWith endpoint pick cid param = pollEndpoint getNext endpoi runExcept $ do (contractResponse :: ContractResponse String s) <- withExcept (ResponseError <<< show) (decodeJSON s) - case contractResponse of - CrPending -> throwError Continue - CrError e -> throwError <<< ResponseError $ e - CrSuccess state -> + case lookup (unwrap endpoint) (unwrap contractResponse).getEndpointResponses of + Just (PRD.Failure e) -> throwError <<< ResponseError $ e + Just (PRD.Success state) -> maybe (throwError <<< ResponseError $ "Invalid state: " <> (show state)) pure (preview pick state) + _ -> throwError Continue getMarketplaceContractId :: forall a. Prism' MarketplaceContracts a -> ContractInstanceClientState MarketplaceContracts -> Maybe ContractId getMarketplaceContractId pick (ContractInstanceClientState st) = (const $ toContractIdParam st.cicContract) <$> (preview pick st.cicDefinition) diff --git a/MetaLamp/nft-marketplace/client/src/Capability/Contract.purs b/MetaLamp/nft-marketplace/client/src/Capability/Contract.purs index 932d4761d..f50462886 100644 --- a/MetaLamp/nft-marketplace/client/src/Capability/Contract.purs +++ b/MetaLamp/nft-marketplace/client/src/Capability/Contract.purs @@ -1,14 +1,13 @@ module Capability.Contract where import Prelude +import Utils.APIError (APIError) import Data.Either (Either) -import Data.Generic.Rep (class Generic) -import Data.Generic.Rep.Show (genericShow) +import Data.Newtype (class Newtype) import Foreign (unsafeToForeign) import Foreign.Generic (class Decode, class Encode) import Halogen (HalogenM, lift) import Plutus.PAB.Webserver.Types (ContractInstanceClientState) -import Utils.APIError newtype ContractId = ContractId String @@ -20,6 +19,8 @@ newtype Endpoint derive newtype instance showEndpoint :: Show Endpoint +derive instance newtypeEndpoint :: Newtype Endpoint _ + data ContractUnit = ContractUnit diff --git a/MetaLamp/nft-marketplace/generate-purs/Main.hs b/MetaLamp/nft-marketplace/generate-purs/Main.hs index 148f98563..1f8c487c2 100644 --- a/MetaLamp/nft-marketplace/generate-purs/Main.hs +++ b/MetaLamp/nft-marketplace/generate-purs/Main.hs @@ -26,8 +26,7 @@ import System.Directory (doesDirectoryExist, myBridge :: BridgePart myBridge = - PAB.pabBridge <|> - ratioBridge + PAB.pabBridge data MyBridge diff --git a/MetaLamp/nft-marketplace/generate-purs/MarketplaceTypes.hs b/MetaLamp/nft-marketplace/generate-purs/MarketplaceTypes.hs index cf8fc9e74..3e8b51734 100644 --- a/MetaLamp/nft-marketplace/generate-purs/MarketplaceTypes.hs +++ b/MetaLamp/nft-marketplace/generate-purs/MarketplaceTypes.hs @@ -31,6 +31,7 @@ import Language.PureScript.Bridge (BridgePart, import Language.PureScript.Bridge.Builder (BridgeData) import Language.PureScript.Bridge.TypeParameters (A, E) import Plutus.Abstract.ContractResponse (ContractResponse) +import Plutus.Abstract.RemoteData (RemoteData) import Plutus.Contract.StateMachine.ThreadToken (ThreadToken) import qualified Plutus.Contracts.NftMarketplace.Endpoints as Marketplace import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Marketplace @@ -38,17 +39,6 @@ import qualified Plutus.Contracts.Services.Sale as Sale import Plutus.PAB.Simulation (MarketplaceContracts (..)) import Plutus.V1.Ledger.Time (DiffMilliSeconds) -ratioBridge :: BridgePart -ratioBridge = do - typeName ^== "Ratio" - typeModule ^== "PlutusTx.Ratio" - psRatio - -psRatio :: MonadReader BridgeData m => m PSType -psRatio = expand <$> psTypeParameters - where - expand [x] = TypeInfo "web-common" "Data.Json.JsonTuple" "JsonTuple" [x, x] - marketplaceTypes :: [SumType 'Haskell] marketplaceTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @ThreadToken) @@ -56,6 +46,7 @@ marketplaceTypes = , (equal <*> (genericShow <*> mkSumType)) (Proxy @MarketplaceContracts) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Marketplace.Marketplace) , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractResponse E A)) + , (equal <*> (genericShow <*> mkSumType)) (Proxy @(RemoteData E A)) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Marketplace.MarketplaceDatum) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Marketplace.UserItemId) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Marketplace.UserContractState) diff --git a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs index e74f46f0b..b4e53c47d 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs @@ -56,7 +56,8 @@ newtype ContractResponse e a = { getEndpointResponses :: Map.Map Prelude.String (RemoteData e a) } deriving (Prelude.Eq, Prelude.Show, Generic) - deriving newtype (J.ToJSON, J.FromJSON, Q.Arbitrary) + deriving anyclass (J.ToJSON, J.FromJSON) + deriving newtype (Q.Arbitrary) instance Semigroup (ContractResponse e a) where (ContractResponse x) <> (ContractResponse y) = ContractResponse $ Map.unionWith (<>) x y