added 'NFT'

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

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