diff --git a/code/week05/plutus-pioneer-program-week05.cabal b/code/week05/plutus-pioneer-program-week05.cabal index a953b99..4fdcf12 100644 --- a/code/week05/plutus-pioneer-program-week05.cabal +++ b/code/week05/plutus-pioneer-program-week05.cabal @@ -11,6 +11,7 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week05.Free + , Week05.NFT , Week05.Signed build-depends: aeson , base ^>=4.14.1.0 diff --git a/code/week05/src/Week05/NFT.hs b/code/week05/src/Week05/NFT.hs new file mode 100644 index 0000000..6b3caa8 --- /dev/null +++ b/code/week05/src/Week05/NFT.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week05.NFT where + +import Control.Monad hiding (fmap) +import Control.Monad.Freer.Extras as Extras +import Data.Aeson (ToJSON, FromJSON) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import Plutus.Contract as Contract hiding (when) +import Plutus.Trace.Emulator as Emulator +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), unless) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value as Value +import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema) +import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) +import Playground.Types (KnownCurrency (..)) +import Prelude (Semigroup (..)) +import Text.Printf (printf) +import Wallet.Emulator.Wallet + +{-# INLINABLE mkPolicy #-} +mkPolicy :: TxOutRef -> TokenName -> ScriptContext -> Bool +mkPolicy oref tn ctx = traceIfFalse "UTxO not consumed" hasUTxO && + traceIfFalse "wrong amount minted" checkMintedAmount + where + info :: TxInfo + info = scriptContextTxInfo ctx + + hasUTxO :: Bool + hasUTxO = any (\i -> txInInfoOutRef i == oref) $ txInfoInputs info + + checkMintedAmount :: Bool + checkMintedAmount = case flattenValue (txInfoForge info) of + [(cs, tn', amt)] -> cs == ownCurrencySymbol ctx && tn' == tn && amt == 1 + _ -> False + +policy :: TxOutRef -> TokenName -> Scripts.MonetaryPolicy +policy oref tn = mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| \oref' tn' -> Scripts.wrapMonetaryPolicy $ mkPolicy oref' tn' ||]) + `PlutusTx.applyCode` + PlutusTx.liftCode oref + `PlutusTx.applyCode` + PlutusTx.liftCode tn + +curSymbol :: TxOutRef -> TokenName -> CurrencySymbol +curSymbol oref tn = scriptCurrencySymbol $ policy oref tn + +type NFTSchema = + BlockchainActions + .\/ Endpoint "mint" TokenName + +mint :: TokenName -> Contract w NFTSchema Text () +mint tn = do + pk <- Contract.ownPubKey + utxos <- utxoAt (pubKeyAddress pk) + case Map.keys utxos of + [] -> Contract.logError @String "no utxo found" + oref : _ -> do + let val = Value.singleton (curSymbol oref tn) tn 1 + lookups = Constraints.monetaryPolicy (policy oref tn) <> Constraints.unspentOutputs utxos + tx = Constraints.mustForgeValue val <> Constraints.mustSpendPubKeyOutput oref + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + Contract.logInfo @String $ printf "forged %s" (show val) + +endpoints :: Contract () NFTSchema Text () +endpoints = mint' >> endpoints + where + mint' = endpoint @"mint" >>= mint + +mkSchemaDefinitions ''NFTSchema + +mkKnownCurrencies [] + +test :: IO () +test = runEmulatorTraceIO $ do + let tn = "ABC" + h1 <- activateContractWallet (Wallet 1) endpoints + h2 <- activateContractWallet (Wallet 2) endpoints + callEndpoint @"mint" h1 tn + callEndpoint @"mint" h2 tn + void $ Emulator.waitNSlots 1