Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
f75d452
commit cf7c6a5
Showing
8 changed files
with
339 additions
and
14 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
76 changes: 76 additions & 0 deletions
76
MetaLamp/nft-marketplace/src/Plutus/Abstract/ContractResponse.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,76 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
|
|
||
| module Plutus.Abstract.ContractResponse where | ||
|
|
||
| import qualified Control.Lens as Lens | ||
| import Control.Monad hiding (fmap) | ||
| import qualified Data.ByteString as BS | ||
| import qualified Data.Map 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 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.OutputValue (OutputValue (..)) | ||
| import qualified Plutus.Abstract.TxUtils as TxUtils | ||
| import Plutus.Contract hiding (when) | ||
| import Plutus.Contracts.Currency as Currency | ||
| import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) | ||
| import qualified Plutus.V1.Ledger.Address as Addr | ||
| import Plutus.V1.Ledger.Value as Value | ||
| import qualified PlutusTx | ||
| import qualified PlutusTx.AssocMap as AssocMap | ||
| import PlutusTx.Prelude hiding (Monoid (..), | ||
| Semigroup (..), mconcat, | ||
| unless) | ||
| import Prelude (Monoid (..), Semigroup (..), | ||
| show, subtract) | ||
| import qualified Prelude | ||
| import Text.Printf (printf) | ||
|
|
||
| data ContractResponse e a = ContractSuccess a | ContractError e | ContractPending | ||
| deriving stock (Prelude.Eq, Show, Generic) | ||
| deriving anyclass (ToJSON, FromJSON) | ||
|
|
||
| instance Semigroup (ContractResponse e a) where | ||
| a <> b = b | ||
|
|
||
| instance Monoid (ContractResponse e a) where | ||
| mempty = ContractPending | ||
| mappend = (<>) | ||
|
|
||
| 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) | ||
| -> Contract (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 |
19 changes: 19 additions & 0 deletions
19
MetaLamp/nft-marketplace/src/Plutus/Abstract/OutputValue.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,19 @@ | ||
| {-# LANGUAGE DeriveFunctor #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE FunctionalDependencies #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
|
|
||
| module Plutus.Abstract.OutputValue where | ||
|
|
||
| import Control.Lens (makeClassy_) | ||
| import Ledger (TxOutRef, TxOutTx) | ||
| import qualified PlutusTx.Prelude as PlutuxTx | ||
|
|
||
| data OutputValue a = | ||
| OutputValue { | ||
| ovOutRef :: TxOutRef, | ||
| ovOutTx :: TxOutTx, | ||
| ovValue :: a | ||
| } deriving (Prelude.Show, Prelude.Functor) | ||
|
|
||
| makeClassy_ ''OutputValue |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,97 @@ | ||
| {-# LANGUAGE ConstraintKinds #-} | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE MultiParamTypeClasses #-} | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeFamilies #-} | ||
|
|
||
| module Plutus.Abstract.TxUtils where | ||
|
|
||
| import Control.Lens (review) | ||
| import Control.Monad (void) | ||
| import Data.ByteString (ByteString) | ||
| import qualified Data.Map as Map | ||
| import Data.Text (Text) | ||
| import Data.Void (Void) | ||
| import Ledger hiding (singleton) | ||
| 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, | ||
| RedeemerType, TypedValidator) | ||
| import qualified Ledger.Typed.Scripts as Scripts | ||
| import Plutus.Abstract.OutputValue (OutputValue (..)) | ||
| import Plutus.Contract | ||
| import Plutus.V1.Ledger.Contexts (ScriptContext, | ||
| scriptCurrencySymbol) | ||
| import qualified Plutus.V1.Ledger.Scripts as Scripts | ||
| import Plutus.V1.Ledger.Value (AssetClass (unAssetClass), | ||
| TokenName (..), assetClass, | ||
| assetClassValue, | ||
| assetClassValueOf) | ||
| import qualified PlutusTx | ||
| import PlutusTx.Prelude hiding (Semigroup (..)) | ||
| import Prelude (Semigroup (..)) | ||
| 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)) | ||
|
|
||
| submitTxPair :: (AsContractError e, IsScriptData a) => | ||
| TxPair a | ||
| -> Contract w s e Tx | ||
| submitTxPair = Prelude.uncurry submitTxConstraintsWith | ||
|
|
||
| mustForgeValue :: (IsScriptData a) => | ||
| MonetaryPolicy | ||
| -> Value | ||
| -> TxPair a | ||
| mustForgeValue policy value = (lookups, tx) | ||
| where | ||
| lookups = Constraints.monetaryPolicy policy | ||
| tx = Constraints.mustForgeValue value | ||
|
|
||
| mustPayToScript :: (IsScriptData a) => | ||
| TypedValidator a | ||
| -> PubKeyHash | ||
| -> DatumType a | ||
| -> Value | ||
| -> TxPair a | ||
| mustPayToScript script pkh datum value = (lookups, tx) | ||
| where | ||
| lookups = Constraints.ownPubKeyHash pkh <> Constraints.typedValidatorLookups script | ||
| tx = Constraints.mustPayToTheScript datum value | ||
|
|
||
| mustSpendScriptOutputs :: (IsScriptData a) => | ||
| TypedValidator a | ||
| -> [OutputValue (RedeemerType a)] | ||
| -> TxPair a | ||
| mustSpendScriptOutputs script inputs = (lookups, tx) | ||
| where | ||
| 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 | ||
|
|
||
| mustSpendFromScript :: (IsScriptData a) => | ||
| TypedValidator a | ||
| -> [OutputValue (RedeemerType a)] | ||
| -> PubKeyHash | ||
| -> Value | ||
| -> TxPair a | ||
| mustSpendFromScript script inputs pkh value = (lookups, tx) <> mustSpendScriptOutputs script inputs | ||
| where | ||
| lookups = Constraints.ownPubKeyHash pkh | ||
| tx = Constraints.mustPayToPubKey pkh value | ||
|
|
||
| mustRoundTripToScript :: (IsScriptData a) => | ||
| TypedValidator a | ||
| -> [OutputValue (RedeemerType a)] | ||
| -> DatumType a | ||
| -> PubKeyHash | ||
| -> Value | ||
| -> TxPair a | ||
| mustRoundTripToScript script inputs datum pkh value = mustSpendScriptOutputs script inputs <> mustPayToScript script pkh datum value |
60 changes: 60 additions & 0 deletions
60
MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/Owner.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1 +1,61 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveAnyClass #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Plutus.Contracts.NftMarketplace.OffChain.Owner where | ||
|
|
||
| import qualified Data.Aeson as J | ||
| import Data.Text (Text) | ||
| import qualified Data.Text as T | ||
| import qualified GHC.Generics as Haskell | ||
| import Ledger | ||
| import qualified Ledger.Typed.Scripts as Scripts | ||
| import Ledger.Value | ||
| import Plutus.Abstract.ContractResponse (ContractResponse, | ||
| withContractResponse) | ||
| import Plutus.Contract | ||
| import Plutus.Contract.StateMachine | ||
| import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core | ||
| import qualified PlutusTx | ||
| import qualified PlutusTx.AssocMap as AssocMap | ||
| import PlutusTx.Prelude hiding | ||
| (Semigroup (..)) | ||
| import Prelude (Semigroup (..)) | ||
| import qualified Prelude as Haskell | ||
| import Control.Monad hiding (fmap) | ||
| import Data.Proxy (Proxy (..)) | ||
| import Plutus.Contracts.Currency as Currency | ||
| import Text.Printf (printf) | ||
|
|
||
| -- | Starts the NFT Marketplace protocol: minting protocol NFT, creating empty nft storage | ||
| start :: () -> Contract w s Text Core.Marketplace | ||
| start () = start' $ do | ||
| pkh <- pubKeyHash <$> ownPubKey | ||
| fmap Currency.currencySymbol $ | ||
| mapError (T.pack . Haskell.show @Currency.CurrencyError) $ | ||
| Currency.forgeContract pkh [(Core.marketplaceProtocolName, 1)] | ||
|
|
||
| start' :: Contract w s Text CurrencySymbol -> Contract w s Text Core.Marketplace | ||
| start' getMarketplaceToken = do | ||
| marketplaceToken <- getMarketplaceToken | ||
| pkh <- pubKeyHash <$> ownPubKey | ||
| let marketplace = Core.marketplace marketplaceToken | ||
| let client = Core.marketplaceClient marketplace | ||
| void $ mapError (T.pack . Haskell.show @SMContractError) $ runInitialise client (Core.MarketplaceDatum AssocMap.empty) mempty | ||
|
|
||
| logInfo @Haskell.String $ printf "started Marketplace %s at address %s" (Haskell.show marketplace) (Haskell.show $ Core.marketplaceAddress marketplace) | ||
| pure marketplace | ||
|
|
||
| type MarketplaceOwnerSchema = | ||
| Endpoint "start" () | ||
|
|
||
| data OwnerContractState = Started Core.Marketplace | ||
| deriving stock (Haskell.Eq, Haskell.Ord, Haskell.Show, Haskell.Generic) | ||
| deriving anyclass (J.ToJSON, J.FromJSON) | ||
|
|
||
| ownerEndpoints :: Contract (ContractResponse Text OwnerContractState) MarketplaceOwnerSchema Void () | ||
| ownerEndpoints = forever $ withContractResponse (Proxy @"start") Started start |
36 changes: 36 additions & 0 deletions
36
MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,36 @@ | ||
| {-# LANGUAGE NoImplicitPrelude #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TypeApplications #-} | ||
|
|
||
| module Plutus.Contracts.NftMarketplace.OnChain.Core | ||
| ( module Export | ||
| , module Plutus.Contracts.NftMarketplace.OnChain.Core | ||
| ) where | ||
|
|
||
| import qualified Data.Aeson as J | ||
| import qualified Data.Text as T | ||
| import qualified GHC.Generics as Haskell | ||
| import Ledger | ||
| import qualified Ledger.Typed.Scripts as Scripts | ||
| import Ledger.Value | ||
| import Plutus.Contract | ||
| import Plutus.Contract.StateMachine | ||
| import Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine as Export | ||
| import qualified PlutusTx | ||
| import qualified PlutusTx.AssocMap as AssocMap | ||
| import PlutusTx.Prelude hiding | ||
| (Semigroup (..)) | ||
| import Prelude (Semigroup (..)) | ||
| import qualified Prelude as Haskell | ||
|
|
||
| marketplaceProtocolName :: TokenName | ||
| marketplaceProtocolName = "NFT Marketplace" | ||
|
|
||
| marketplace :: CurrencySymbol -> Marketplace | ||
| marketplace protocol = Marketplace (assetClass protocol marketplaceProtocolName) | ||
|
|
||
| marketplaceValidator :: Marketplace -> Validator | ||
| marketplaceValidator = Scripts.validatorScript . marketplaceInst | ||
|
|
||
| marketplaceAddress :: Marketplace -> Ledger.Address | ||
| marketplaceAddress = scriptAddress . marketplaceValidator |
Oops, something went wrong.