Skip to content

Commit

Permalink
Merge pull request #84 from input-output-hk/Metalamp/nft-marketplace/…
Browse files Browse the repository at this point in the history
…fix-contract-response

Metalamp/nft marketplace/fix contract response
  • Loading branch information
olgaklimenko committed Oct 4, 2021
2 parents 79ee9cb + 380ea5d commit 6f10cb1
Show file tree
Hide file tree
Showing 15 changed files with 319 additions and 125 deletions.
17 changes: 10 additions & 7 deletions MetaLamp/nft-marketplace/client/src/Business/Marketplace.purs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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)
Expand Down
7 changes: 4 additions & 3 deletions MetaLamp/nft-marketplace/client/src/Capability/Contract.purs
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -20,6 +19,8 @@ newtype Endpoint

derive newtype instance showEndpoint :: Show Endpoint

derive instance newtypeEndpoint :: Newtype Endpoint _

data ContractUnit
= ContractUnit

Expand Down
3 changes: 1 addition & 2 deletions MetaLamp/nft-marketplace/generate-purs/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,8 +26,7 @@ import System.Directory (doesDirectoryExist,

myBridge :: BridgePart
myBridge =
PAB.pabBridge <|>
ratioBridge
PAB.pabBridge

data MyBridge

Expand Down
13 changes: 2 additions & 11 deletions MetaLamp/nft-marketplace/generate-purs/MarketplaceTypes.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,31 +31,22 @@ 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
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)
, (equal <*> (genericShow <*> mkSumType)) (Proxy @DiffMilliSeconds)
, (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)
Expand Down
6 changes: 4 additions & 2 deletions MetaLamp/nft-marketplace/plutus-starter.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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.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,
Expand All @@ -59,6 +59,7 @@ library
servant-server,
wai-cors,
servant-options,
QuickCheck,
-- Plutus:
playground-common,
plutus-contract,
Expand Down Expand Up @@ -116,7 +117,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.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,
Expand Down Expand Up @@ -144,6 +145,7 @@ test-suite test
mtl -any,
row-types -any,
QuickCheck -any,
quickcheck-properties -any,
freer-simple -any,
foldl -any,
streaming -any
80 changes: 51 additions & 29 deletions MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs
Original file line number Diff line number Diff line change
@@ -1,35 +1,40 @@
{-# 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
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)
Expand All @@ -43,38 +48,55 @@ 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 anyclass (J.ToJSON, J.FromJSON)
deriving newtype (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)
=> Proxy l
-> (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
110 changes: 110 additions & 0 deletions MetaLamp/nft-marketplace/src/Plutus/Abstract/RemoteData.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,110 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Plutus.Abstract.RemoteData where

import qualified Control.Lens as Lens
import qualified Control.Lens.Extras as Lens
import qualified Data.Aeson as J
import GHC.Generics (Generic)
import Prelude hiding (maybe)
import qualified Test.QuickCheck as Q

-- | A datatype representing fetched data.
-- |
-- | If you find yourself continually using `Maybe (Either e a)` to
-- | represent data loaded from an external source, or you have a
-- | habit of shuffling errors away to where they can be quietly
-- | ignored, consider using this. It makes it easier to represent the
-- | real state of a remote data fetch and handle it properly.
-- |
-- | For more on the motivation, take a look at the blog post
-- | [How Elm Slays A UI Antipattern](http://blog.jenkster.com/2016/06/how-elm-slays-a-ui-antipattern.html).
-- | This is a port of that original Elm module.
data RemoteData e a
= NotAsked
| Loading
| Failure e
| Success a
deriving stock (Generic, Eq, Functor, Show, Foldable, Traversable)
deriving anyclass (J.FromJSON, J.ToJSON)
-- TODO implement Applicative Monad Bifunctor MonadThrow MonadError Bifoldable Bitraversable

Lens.makeClassyPrisms ''RemoteData

instance Semigroup (RemoteData e a) where
NotAsked <> x = x
x <> NotAsked = x
x <> y = y

instance Monoid (RemoteData e a) where
mempty = NotAsked

instance (Q.Arbitrary e, Q.Arbitrary a) => Q.Arbitrary (RemoteData e a) where
arbitrary = do
err <- Q.arbitrary
res <- Q.arbitrary
Q.elements [ NotAsked
, Loading
, Failure err
, Success res]

------------------------------------------------------------

-- | Convert a `RemoteData` to a `Maybe`.
toMaybe :: forall e a. RemoteData e a -> Maybe a
toMaybe (Success value) = Just value
toMaybe _ = Nothing

-- | Convert a `Maybe` to `RemoteData`.
fromMaybe :: forall e a. Maybe a -> RemoteData e a
fromMaybe Nothing = NotAsked
fromMaybe (Just value) = Success value

-- | Convert an `Either` to `RemoteData`
fromEither :: forall e a. Either e a -> RemoteData e a
fromEither (Left err) = Failure err
fromEither (Right value) = Success value

-- | Takes a default value, a function, and a `RemoteData` value. If
-- | the data is `Success`, apply the function to the value, otherwise
-- | return the default.
-- |
-- | See also `withDefault`.
maybe :: forall e a b. b -> (a -> b) -> RemoteData e a -> b
maybe default' f (Success value) = f value
maybe default' f _ = default'

-- | If the `RemoteData` has been successfully loaded, return that,
-- | otherwise return a default value.
withDefault :: forall e a. a -> RemoteData e a -> a
withDefault default' = maybe default' id

------------------------------------------------------------

-- | Simple predicate.
isNotAsked :: forall e a. RemoteData e a -> Bool
isNotAsked = Lens.is _NotAsked

-- | Simple predicate.
isLoading :: forall e a. RemoteData e a -> Bool
isLoading = Lens.is _Loading

-- | Simple predicate.
isFailure :: forall e a. RemoteData e a -> Bool
isFailure = Lens.is _Failure

-- | Simple predicate.
isSuccess :: forall e a. RemoteData e a -> Bool
isSuccess = Lens.is _Success

0 comments on commit 6f10cb1

Please sign in to comment.