added 'NFT'

This commit is contained in:
Lars Brünjes 2021-05-04 22:25:32 +02:00
parent 1c57956054
commit 86c61c3592
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
2 changed files with 99 additions and 0 deletions

View file

@ -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

View file

@ -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