diff --git a/MetaLamp/nft-marketplace/plutus-starter.cabal b/MetaLamp/nft-marketplace/plutus-starter.cabal index ac015e431..c7d10eda5 100644 --- a/MetaLamp/nft-marketplace/plutus-starter.cabal +++ b/MetaLamp/nft-marketplace/plutus-starter.cabal @@ -23,7 +23,7 @@ maintainer: Your email library exposed-modules: - Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Contexts Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Contracts.NftMarketplace.Endpoints Plutus.Contracts.NftMarketplace.OffChain.Owner Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine Plutus.PAB.Simulation + Plutus.Contracts.NftMarketplace.OnChain.Core Plutus.Contracts.Services.Sale Plutus.Contracts.Services.Sale.Endpoints Plutus.Contracts.Services.Sale.StateMachine Plutus.Contracts.NftMarketplace.OffChain.Info Ext.Plutus.Ledger.Contexts Ext.Plutus.Ledger.Value Plutus.Contracts.NftMarketplace.OffChain.User Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils 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/Contracts/NftMarketplace/OffChain/User.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs index 016d8459a..8e0e65c55 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OffChain/User.hs @@ -13,6 +13,7 @@ module Plutus.Contracts.NftMarketplace.OffChain.User where +import Control.Lens ((^.)) import qualified Control.Lens as Lens import Control.Monad hiding (fmap) import qualified Data.Aeson as J @@ -24,7 +25,7 @@ import qualified GHC.Generics as Haskell import Ledger import qualified Ledger.Typed.Scripts as Scripts import Ledger.Typed.Tx -import Ledger.Value +import qualified Ledger.Value as V import Plutus.Abstract.ContractResponse (ContractResponse, withContractResponse) import Plutus.Contract @@ -34,6 +35,7 @@ import Plutus.Contracts.NftMarketplace.OffChain.Info (fundsAt, mapError', marketplaceStore) import qualified Plutus.Contracts.NftMarketplace.OnChain.Core as Core +import qualified Plutus.Contracts.Services.Sale as Sale import qualified PlutusTx import qualified PlutusTx.AssocMap as AssocMap import PlutusTx.Prelude hiding @@ -43,6 +45,9 @@ import qualified Prelude as Haskell import qualified Schema import Text.Printf (printf) +getOwnPubKey :: Contract w s Text PubKeyHash +getOwnPubKey = pubKeyHash <$> ownPubKey + data CreateNftParams = CreateNftParams { cnpIpfsCid :: ByteString, @@ -56,7 +61,7 @@ data CreateNftParams = PlutusTx.unstableMakeIsData ''CreateNftParams PlutusTx.makeLift ''CreateNftParams --- | The user specifizes which NFT to mint and add to marketplace store, +-- | The user specifies which NFT to mint and add to marketplace store, -- he gets it into his wallet and the corresponding store entry is created createNft :: Core.Marketplace -> CreateNftParams -> Contract w s Text () createNft marketplace CreateNftParams {..} = do @@ -65,7 +70,7 @@ createNft marketplace CreateNftParams {..} = do when (isJust $ AssocMap.lookup ipfsCidHash nftStore) $ throwError "Nft entry already exists" pkh <- getOwnPubKey - let tokenName = TokenName cnpIpfsCid + let tokenName = V.TokenName cnpIpfsCid nft <- mapError (T.pack . Haskell.show @Currency.CurrencyError) $ Currency.forgeContract pkh [(tokenName, 1)] @@ -76,29 +81,119 @@ createNft marketplace CreateNftParams {..} = do , nftName = cnpNftName , nftDescription = cnpNftDescription , nftIssuer = if cnpRevealIssuer then Just pkh else Nothing - , nftIpfsCid = Nothing + , nftSale = Nothing -- TODO validate that it's Nothing } void $ mapError' $ runStep client $ Core.CreateNftRedeemer ipfsCidHash nftEntry logInfo @Haskell.String $ printf "Created NFT %s with store entry %s" (Haskell.show nft) (Haskell.show nftEntry) pure () -balanceAt :: PubKeyHash -> AssetClass -> Contract w s Text Integer -balanceAt pkh asset = flip assetClassValueOf asset <$> fundsAt pkh +data OpenSaleParams = + OpenSaleParams { + ospIpfsCid :: ByteString, + ospSalePrice :: Sale.LovelacePrice + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) -getOwnPubKey :: Contract w s Text PubKeyHash -getOwnPubKey = pubKeyHash <$> ownPubKey +PlutusTx.unstableMakeIsData ''OpenSaleParams +PlutusTx.makeLift ''OpenSaleParams + +-- | The user opens sale for his NFT +openSale :: Core.Marketplace -> OpenSaleParams -> Contract w s Text () +openSale marketplace OpenSaleParams {..} = do + let ipfsCidHash = sha2_256 ospIpfsCid + nftStore <- marketplaceStore marketplace + nftEntry <- maybe (throwError "NFT has not been created") pure $ AssocMap.lookup ipfsCidHash nftStore + let tokenName = V.TokenName ospIpfsCid + + sale <- Sale.openSale + Sale.OpenSaleParams { + ospSalePrice = ospSalePrice, + ospSaleValue = V.singleton (Core.nftId nftEntry) tokenName 1 + } + + let client = Core.marketplaceClient marketplace + let lot = Core.Lot + { lotSale = Sale.toTuple sale + , lotIpfsCid = ospIpfsCid + } + void $ mapError' $ runStep client $ Core.OpenSaleRedeemer ipfsCidHash lot + + logInfo @Haskell.String $ printf "Created NFT sale %s" (Haskell.show lot) + pure () + +data BuyNftParams = + BuyNftParams { + bnpIpfsCid :: ByteString + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''BuyNftParams +PlutusTx.makeLift ''BuyNftParams + +-- | The user buys specified NFT lot +buyNft :: Core.Marketplace -> BuyNftParams -> Contract w s Text () +buyNft marketplace BuyNftParams {..} = do + let ipfsCidHash = sha2_256 bnpIpfsCid + nftStore <- marketplaceStore marketplace + nftEntry <- maybe (throwError "NFT has not been created") pure $ AssocMap.lookup ipfsCidHash nftStore + nftLot <- maybe (throwError "NFT has not been put on sale") pure $ nftEntry ^. Core._nftSale + + _ <- Sale.buyLot $ Sale.fromTuple $ nftLot ^. Core._lotSale + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.BuyNftRedeemer ipfsCidHash + + logInfo @Haskell.String $ printf "Bought NFT lot %s" (Haskell.show nftLot) + pure () + +data CloseSaleParams = + CloseSaleParams { + cspIpfsCid :: ByteString + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''CloseSaleParams +PlutusTx.makeLift ''CloseSaleParams + +-- | The user closes NFT sale and receives his token back +closeSale :: Core.Marketplace -> CloseSaleParams -> Contract w s Text () +closeSale marketplace CloseSaleParams {..} = do + let ipfsCidHash = sha2_256 cspIpfsCid + nftStore <- marketplaceStore marketplace + nftEntry <- maybe (throwError "NFT has not been created") pure $ AssocMap.lookup ipfsCidHash nftStore + nftLot <- maybe (throwError "NFT has not been put on sale") pure $ nftEntry ^. Core._nftSale + + _ <- Sale.redeemLot $ Sale.fromTuple $ nftLot ^. Core._lotSale + + let client = Core.marketplaceClient marketplace + void $ mapError' $ runStep client $ Core.CloseSaleRedeemer ipfsCidHash + + logInfo @Haskell.String $ printf "Closed NFT lot sale %s" (Haskell.show nftLot) + pure () + +balanceAt :: PubKeyHash -> AssetClass -> Contract w s Text Integer +balanceAt pkh asset = flip V.assetClassValueOf asset <$> fundsAt pkh ownPubKeyBalance :: Contract w s Text Value ownPubKeyBalance = getOwnPubKey >>= fundsAt type MarketplaceUserSchema = Endpoint "createNft" CreateNftParams + .\/ Endpoint "openSale" OpenSaleParams + .\/ Endpoint "buyNft" BuyNftParams + .\/ Endpoint "closeSale" CloseSaleParams .\/ Endpoint "ownPubKey" () .\/ Endpoint "ownPubKeyBalance" () data UserContractState = NftCreated + | OpenedSale + | NftBought + | ClosedSale | GetPubKey PubKeyHash | GetPubKeyBalance Value deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) @@ -109,5 +204,8 @@ Lens.makeClassyPrisms ''UserContractState userEndpoints :: Core.Marketplace -> Contract (ContractResponse Text UserContractState) MarketplaceUserSchema Void () userEndpoints marketplace = forever $ withContractResponse (Proxy @"createNft") (const NftCreated) (createNft marketplace) + `select` withContractResponse (Proxy @"openSale") (const OpenedSale) (openSale marketplace) + `select` withContractResponse (Proxy @"buyNft") (const NftBought) (buyNft marketplace) + `select` withContractResponse (Proxy @"closeSale") (const ClosedSale) (closeSale marketplace) `select` withContractResponse (Proxy @"ownPubKey") GetPubKey (const getOwnPubKey) `select` withContractResponse (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance) diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs index 31f08beee..e6454ec45 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/NftMarketplace/OnChain/Core/StateMachine.hs @@ -11,20 +11,23 @@ module Plutus.Contracts.NftMarketplace.OnChain.Core.StateMachine where -import qualified Data.Aeson as J -import qualified Data.Text as T -import qualified GHC.Generics as Haskell +import Control.Lens ((&), (.~), (?~), (^.)) +import qualified Control.Lens as Lens +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified GHC.Generics as Haskell import Ledger -import qualified Ledger.Constraints as Constraints -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Value +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import qualified Ledger.Value as V import Plutus.Contract import Plutus.Contract.StateMachine +import qualified Plutus.Contracts.Services.Sale as Sale import qualified PlutusTx -import qualified PlutusTx.AssocMap as AssocMap -import PlutusTx.Prelude hiding (Semigroup (..)) -import Prelude (Semigroup (..)) -import qualified Prelude as Haskell +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell newtype Marketplace = Marketplace @@ -36,6 +39,20 @@ newtype Marketplace = PlutusTx.makeLift ''Marketplace type IpfsCidHash = ByteString +type Sale = (AssetClass, Sale.LovelacePrice, Value) + +data Lot = Lot + { lotSale :: Sale + , lotIpfsCid :: ByteString + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON) + +PlutusTx.unstableMakeIsData ''Lot + +PlutusTx.makeLift ''Lot + +Lens.makeClassy_ ''Lot data NFT = NFT @@ -43,7 +60,7 @@ data NFT = , nftName :: ByteString , nftDescription :: ByteString , nftIssuer :: Maybe PubKeyHash - , nftIpfsCid :: Maybe ByteString + , nftSale :: Maybe Lot } deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) deriving anyclass (J.ToJSON, J.FromJSON) @@ -52,15 +69,20 @@ PlutusTx.unstableMakeIsData ''NFT PlutusTx.makeLift ''NFT +Lens.makeClassy_ ''NFT + data MarketplaceRedeemer = CreateNftRedeemer IpfsCidHash NFT + | OpenSaleRedeemer IpfsCidHash Lot + | BuyNftRedeemer IpfsCidHash + | CloseSaleRedeemer IpfsCidHash deriving (Haskell.Show) PlutusTx.unstableMakeIsData ''MarketplaceRedeemer PlutusTx.makeLift ''MarketplaceRedeemer -data MarketplaceDatum = +newtype MarketplaceDatum = MarketplaceDatum { getMarketplaceDatum :: AssocMap.Map IpfsCidHash NFT } @@ -74,14 +96,38 @@ PlutusTx.makeLift ''MarketplaceDatum transition :: Marketplace -> State MarketplaceDatum -> MarketplaceRedeemer -> Maybe (TxConstraints Void Void, State MarketplaceDatum) transition marketplace state redeemer = case redeemer of CreateNftRedeemer ipfsCidHash nftEntry + -- TODO check that ipfsCidHash is a hash (?) -> Just ( mustBeSignedByIssuer nftEntry - , State (MarketplaceDatum $ AssocMap.insert ipfsCidHash nftEntry nftStore) mempty + , State (MarketplaceDatum $ AssocMap.insert ipfsCidHash nftEntry nftStore) currStateValue ) + OpenSaleRedeemer ipfsCidHash lot + -> let newEntry = maybe (traceError "NFT has not been created.") (_nftSale ?~ lot) $ + AssocMap.lookup ipfsCidHash nftStore + in Just ( mempty + , State (MarketplaceDatum $ AssocMap.insert ipfsCidHash newEntry nftStore) currStateValue + ) + BuyNftRedeemer ipfsCidHash + -> let newEntry = maybe (traceError "NFT has not been created.") (_nftSale .~ Nothing) $ + AssocMap.lookup ipfsCidHash nftStore + in Just ( mempty + , State (MarketplaceDatum $ AssocMap.insert ipfsCidHash newEntry nftStore) currStateValue + ) + CloseSaleRedeemer ipfsCidHash + -> let newEntry = maybe (traceError "NFT has not been created.") (_nftSale .~ Nothing) $ + AssocMap.lookup ipfsCidHash nftStore + in Just ( mempty + , State (MarketplaceDatum $ AssocMap.insert ipfsCidHash newEntry nftStore) currStateValue + ) _ -> Nothing where + stateToken :: Value + stateToken = V.assetClassValue (marketplaceProtocolToken marketplace) 1 + nftStore :: AssocMap.Map IpfsCidHash NFT nftStore = getMarketplaceDatum $ stateData state + currStateValue = stateValue state - stateToken + mustBeSignedByIssuer entry = case nftIssuer entry of Just pkh -> Constraints.mustBeSignedBy pkh Nothing -> mempty @@ -89,8 +135,29 @@ transition marketplace state redeemer = case redeemer of {-# INLINABLE stateTransitionCheck #-} stateTransitionCheck :: MarketplaceDatum -> MarketplaceRedeemer -> ScriptContext -> Bool stateTransitionCheck (MarketplaceDatum nftStore) (CreateNftRedeemer ipfsCidHash nftEntry) ctx = - traceIfFalse "Nft entry already exists" $ + traceIfFalse "CreateNftRedeemer: " $ + traceIfFalse "NFT entry already exists" $ isNothing $ AssocMap.lookup ipfsCidHash nftStore +stateTransitionCheck (MarketplaceDatum nftStore) (OpenSaleRedeemer ipfsCidHash lot) ctx = + traceIfFalse "OpenSaleRedeemer: " $ + let nftEntry = fromMaybe (traceError "NFT has not been created") $ AssocMap.lookup ipfsCidHash nftStore + nftIpfsCid = lotIpfsCid lot + sale = Sale.fromTuple $ lotSale lot + nftValue = V.singleton (nftId nftEntry) (V.TokenName nftIpfsCid) 1 + hasBeenPutOnSale = Sale.saleValue sale == nftValue + isValidHash = sha2_256 nftIpfsCid == ipfsCidHash + in traceIfFalse "NFT has not been put on sale" hasBeenPutOnSale && + traceIfFalse "Invalid IPFS Cid Hash" isValidHash +stateTransitionCheck (MarketplaceDatum nftStore) (BuyNftRedeemer ipfsCidHash) ctx = + traceIfFalse "BuyNftRedeemer: " $ + let nftEntry = fromMaybe (traceError "NFT has not been created") $ AssocMap.lookup ipfsCidHash nftStore + hasBeenPutOnSale = isJust $ nftSale nftEntry + in traceIfFalse "NFT has not been put on sale" hasBeenPutOnSale +stateTransitionCheck (MarketplaceDatum nftStore) (CloseSaleRedeemer ipfsCidHash) ctx = + traceIfFalse "CloseSaleRedeemer: " $ + let nftEntry = fromMaybe (traceError "NFT has not been created") $ AssocMap.lookup ipfsCidHash nftStore + hasBeenPutOnSale = isJust $ nftSale nftEntry + in traceIfFalse "NFT has not been put on sale" hasBeenPutOnSale {-# INLINABLE marketplaceStateMachine #-} marketplaceStateMachine :: Marketplace -> StateMachine MarketplaceDatum MarketplaceRedeemer diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs new file mode 100644 index 000000000..1d26ba469 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale.hs @@ -0,0 +1,4 @@ +module Plutus.Contracts.Services.Sale (module Export) where + +import Plutus.Contracts.Services.Sale.Endpoints as Export +import Plutus.Contracts.Services.Sale.StateMachine as Export diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs new file mode 100644 index 000000000..280900350 --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/Endpoints.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.Services.Sale.Endpoints where + +import Control.Monad hiding (fmap) +import qualified Data.Aeson as J +import Data.Proxy (Proxy (..)) +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 Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.Services.Sale.StateMachine 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 qualified Schema +import Text.Printf (printf) + +data OpenSaleParams = + OpenSaleParams { + ospSalePrice :: Core.LovelacePrice, + ospSaleValue :: Value + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''OpenSaleParams +PlutusTx.makeLift ''OpenSaleParams + +-- | Starts the Sale protocol and mints protocol NFT +openSale :: OpenSaleParams -> Contract w s Text Core.Sale +openSale OpenSaleParams {..} = do + pkh <- getOwnPubKey + saleCurrency <- fmap Currency.currencySymbol $ + mapError (T.pack . Haskell.show @Currency.CurrencyError) $ + Currency.forgeContract pkh [(Core.saleProtocolName, 1)] + let sale = Core.Sale + { saleProtocolToken = assetClass saleCurrency Core.saleProtocolName, + salePrice = ospSalePrice, + saleValue = ospSaleValue + } + let client = Core.saleClient sale + void $ mapError (T.pack . Haskell.show @SMContractError) $ runInitialise client (Core.LotInfo pkh) ospSaleValue + + logInfo @Haskell.String $ printf "Opened Sale %s at address %s" (Haskell.show sale) (Haskell.show $ Core.saleAddress sale) + pure sale + +-- | The user buys sale value paying sale price +buyLot :: Core.Sale -> Contract w s Text () +buyLot sale = do + pkh <- getOwnPubKey + let client = Core.saleClient sale + void $ mapError' $ runStep client $ Core.Buy pkh + + logInfo @Haskell.String $ printf "User %s bought lot from sale %s" (Haskell.show pkh) (Haskell.show sale) + pure () + +-- | The user redeems sale value and sale protocol token +redeemLot :: Core.Sale -> Contract w s Text () +redeemLot sale = do + pkh <- getOwnPubKey + let client = Core.saleClient sale + void $ mapError' $ runStep client Core.Redeem + + logInfo @Haskell.String $ printf "User %s redeemed lot from sale %s" (Haskell.show pkh) (Haskell.show sale) + pure () + +getOwnPubKey :: Contract w s Text PubKeyHash +getOwnPubKey = pubKeyHash <$> ownPubKey + +mapError' :: Contract w s SMContractError a -> Contract w s Text a +mapError' = mapError $ T.pack . Haskell.show diff --git a/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs new file mode 100644 index 000000000..4550440eb --- /dev/null +++ b/MetaLamp/nft-marketplace/src/Plutus/Contracts/Services/Sale/StateMachine.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Plutus.Contracts.Services.Sale.StateMachine where + +import qualified Control.Lens as Lens +import qualified Data.Aeson as J +import qualified Data.Text as T +import qualified GHC.Generics as Haskell +import Ledger +import qualified Ledger.Ada as Ada +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value +import Plutus.Contract +import Plutus.Contract.StateMachine +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..)) +import qualified Prelude as Haskell +import qualified Schema + +type Saler = PubKeyHash +type Buyer = PubKeyHash +type LovelacePrice = Integer + +data Sale = + Sale + { saleProtocolToken :: AssetClass, + salePrice :: LovelacePrice, + saleValue :: Value + } + deriving stock (Haskell.Eq, Haskell.Show, Haskell.Generic) + deriving anyclass (J.ToJSON, J.FromJSON, Schema.ToSchema) + +PlutusTx.unstableMakeIsData ''Sale + +PlutusTx.makeLift ''Sale + +Lens.makeClassy_ ''Sale + +{-# INLINABLE toTuple #-} +toTuple :: Sale -> (AssetClass, LovelacePrice, Value) +toTuple Sale{..} = (saleProtocolToken, salePrice, saleValue) + +{-# INLINABLE fromTuple #-} +fromTuple :: (AssetClass, LovelacePrice, Value) -> Sale +fromTuple (saleProtocolToken, salePrice, saleValue) = Sale{..} + +data SaleRedeemer + = Buy Buyer + | Redeem + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''SaleRedeemer + +PlutusTx.makeLift ''SaleRedeemer + +data SaleDatum = + LotInfo Saler + | SaleClosed + deriving (Haskell.Show) + +PlutusTx.unstableMakeIsData ''SaleDatum + +PlutusTx.makeLift ''SaleDatum + +{-# INLINABLE transition #-} +transition :: Sale -> State SaleDatum -> SaleRedeemer -> Maybe (TxConstraints Void Void, State SaleDatum) +transition Sale{..} state redeemer = case (stateData state, redeemer) of + (LotInfo saler, Redeem) + -> Just ( Constraints.mustBeSignedBy saler <> + Constraints.mustPayToPubKey saler val + , State SaleClosed mempty + ) + (LotInfo saler, Buy buyer) | saleValue == (val - stateToken) + -> Just ( Constraints.mustBeSignedBy buyer <> + Constraints.mustPayToPubKey saler (stateToken <> Ada.lovelaceValueOf salePrice) <> + Constraints.mustPayToPubKey buyer saleValue + , State SaleClosed mempty + ) + _ -> Nothing + where + stateToken :: Value + stateToken = assetClassValue saleProtocolToken 1 + + val = stateValue state + +{-# INLINABLE isFinal #-} +isFinal :: SaleDatum -> Bool +isFinal SaleClosed = True +isFinal _ = False + +{-# INLINABLE saleStateMachine #-} +saleStateMachine :: Sale -> StateMachine SaleDatum SaleRedeemer +saleStateMachine sale = StateMachine + { smTransition = transition sale + , smFinal = isFinal + , smCheck = \d r ctx -> True + , smThreadToken = Just $ saleProtocolToken sale + } + +{-# INLINABLE mkSaleValidator #-} +mkSaleValidator :: Sale -> SaleDatum -> SaleRedeemer -> ScriptContext -> Bool +mkSaleValidator sale = mkValidator $ saleStateMachine sale + +type SaleScript = StateMachine SaleDatum SaleRedeemer + +saleInst :: Sale -> Scripts.TypedValidator SaleScript +saleInst sale = Scripts.mkTypedValidator @SaleScript + ($$(PlutusTx.compile [|| mkSaleValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode sale) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @SaleDatum @SaleRedeemer + +saleClient :: Sale -> StateMachineClient SaleDatum SaleRedeemer +saleClient sale = mkStateMachineClient $ StateMachineInstance (saleStateMachine sale) (saleInst sale) + +saleProtocolName :: TokenName +saleProtocolName = "Sale" + +saleValidator :: Sale -> Validator +saleValidator = Scripts.validatorScript . saleInst + +saleAddress :: Sale -> Ledger.Address +saleAddress = scriptAddress . saleValidator diff --git a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs index 8efd65663..8a6070864 100644 --- a/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/nft-marketplace/src/Plutus/PAB/Simulation.hs @@ -47,6 +47,7 @@ import Plutus.Contract hiding (when) import Plutus.Contracts.Currency as Currency 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.Effects.Contract (ContractEffect (..)) import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), @@ -98,11 +99,13 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do ContractIDs {..} <- activateContracts let userCid = cidUser Map.! Wallet 2 sender = pubKeyHash . walletPubKey $ Wallet 2 + let catTokenIpfsCid = "QmPeoJnaDttpFrSySYBY3reRFCzL3qv4Uiqz376EBv9W16" + let photoTokenIpfsCid = "QmeSFBsEZ7XtK7yv5CQ79tqFnH9V2jhFhSSq1LV5W3kuiB" _ <- Simulator.callEndpointOnInstance userCid "createNft" $ Marketplace.CreateNftParams { - cnpIpfsCid = "QmPeoJnaDttpFrSySYBY3reRFCzL3qv4Uiqz376EBv9W16", + cnpIpfsCid = catTokenIpfsCid, cnpNftName = "Cat token", cnpNftDescription = "A picture of a cat on a pogo stick", cnpRevealIssuer = False @@ -112,11 +115,68 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do _ -> Nothing Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" - _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" sender + _ <- + Simulator.callEndpointOnInstance userCid "openSale" $ + Marketplace.OpenSaleParams { + ospIpfsCid = catTokenIpfsCid, + ospSalePrice = 44*oneAdaInLovelace + } + sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of + Success (ContractSuccess Marketplace.OpenedSale) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" + + let buyerCid = cidUser Map.! Wallet 3 + buyer = pubKeyHash . walletPubKey $ Wallet 3 + + _ <- + Simulator.callEndpointOnInstance buyerCid "buyNft" Marketplace.BuyNftParams { + bnpIpfsCid = catTokenIpfsCid + } + _ <- flip Simulator.waitForState buyerCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of + Success (ContractSuccess Marketplace.NftBought) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful buyNft" + + _ <- + Simulator.callEndpointOnInstance userCid "createNft" $ + Marketplace.CreateNftParams { + cnpIpfsCid = photoTokenIpfsCid, + cnpNftName = "Photo token", + cnpNftDescription = "A picture of a sunset", + cnpRevealIssuer = True + } + flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of + Success (ContractSuccess Marketplace.NftCreated) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful createNft" + + _ <- + Simulator.callEndpointOnInstance userCid "openSale" $ + Marketplace.OpenSaleParams { + ospIpfsCid = photoTokenIpfsCid, + ospSalePrice = 12*oneAdaInLovelace + } + sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of + Success (ContractSuccess Marketplace.OpenedSale) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful openSale" + + _ <- + Simulator.callEndpointOnInstance userCid "closeSale" + Marketplace.CloseSaleParams { + cspIpfsCid = photoTokenIpfsCid + } + sale <- flip Simulator.waitForState userCid $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.UserContractState)) of + Success (ContractSuccess Marketplace.ClosedSale) -> Just () + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Successful closeSale" + + _ <- Simulator.callEndpointOnInstance cidInfo "fundsAt" buyer v <- flip Simulator.waitForState cidInfo $ \json -> case (fromJSON json :: Result (ContractResponse Text Marketplace.InfoContractState)) of Success (ContractSuccess (Marketplace.FundsAt v)) -> Just v _ -> Nothing - Simulator.logString @(Builtin MarketplaceContracts) $ "Final user funds: " <> show v + 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 @@ -130,6 +190,12 @@ runNftMarketplace = void $ Simulator.runSimulationWith handlers $ do _ -> 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 (ContractSuccess (Marketplace.FundsAt v)) -> Just v + _ -> Nothing + Simulator.logString @(Builtin MarketplaceContracts) $ "Final user funds: " <> show v + _ <- liftIO getLine shutdown