From c1dc67e8d4e681cccd3cb83e48f8c313477305c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 4 May 2021 23:17:36 +0200 Subject: [PATCH] sample solutions for week 5 --- .../plutus-pioneer-program-week05.cabal | 2 + code/week05/src/Week05/Solution1.hs | 104 ++++++++++++++++++ code/week05/src/Week05/Solution2.hs | 96 ++++++++++++++++ 3 files changed, 202 insertions(+) create mode 100644 code/week05/src/Week05/Solution1.hs create mode 100644 code/week05/src/Week05/Solution2.hs diff --git a/code/week05/plutus-pioneer-program-week05.cabal b/code/week05/plutus-pioneer-program-week05.cabal index 4151025..7015503 100644 --- a/code/week05/plutus-pioneer-program-week05.cabal +++ b/code/week05/plutus-pioneer-program-week05.cabal @@ -15,6 +15,8 @@ library , Week05.Homework2 , Week05.NFT , Week05.Signed + , Week05.Solution1 + , Week05.Solution2 build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week05/src/Week05/Solution1.hs b/code/week05/src/Week05/Solution1.hs new file mode 100644 index 0000000..09ae73c --- /dev/null +++ b/code/week05/src/Week05/Solution1.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week05.Solution1 where + +import Control.Monad hiding (fmap) +import Data.Aeson (ToJSON, FromJSON) +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 :: PubKeyHash -> Slot -> ScriptContext -> Bool +mkPolicy pkh deadline ctx = + traceIfFalse "signature missing" (txSignedBy info pkh) && + traceIfFalse "deadline missed" (to deadline `contains` txInfoValidRange info) + where + info = scriptContextTxInfo ctx + +policy :: PubKeyHash -> Slot -> Scripts.MonetaryPolicy +policy pkh deadline = mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| \pkh' deadline' -> Scripts.wrapMonetaryPolicy $ mkPolicy pkh' deadline' ||]) + `PlutusTx.applyCode` + PlutusTx.liftCode pkh + `PlutusTx.applyCode` + PlutusTx.liftCode deadline + +curSymbol :: PubKeyHash -> Slot -> CurrencySymbol +curSymbol pkh deadline = scriptCurrencySymbol $ policy pkh deadline + +data MintParams = MintParams + { mpTokenName :: !TokenName + , mpDeadline :: !Slot + , mpAmount :: !Integer + } deriving (Generic, ToJSON, FromJSON, ToSchema) + +type SignedSchema = + BlockchainActions + .\/ Endpoint "mint" MintParams + +mint :: MintParams -> Contract w SignedSchema Text () +mint mp = do + pkh <- pubKeyHash <$> Contract.ownPubKey + now <- Contract.currentSlot + let deadline = mpDeadline mp + if now > deadline + then Contract.logError @String "deadline passed" + else do + let val = Value.singleton (curSymbol pkh deadline) (mpTokenName mp) (mpAmount mp) + lookups = Constraints.monetaryPolicy $ policy pkh deadline + tx = Constraints.mustForgeValue val <> Constraints.mustValidateIn (to deadline) + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + Contract.logInfo @String $ printf "forged %s" (show val) + +endpoints :: Contract () SignedSchema Text () +endpoints = mint' >> endpoints + where + mint' = endpoint @"mint" >>= mint + +mkSchemaDefinitions ''SignedSchema + +mkKnownCurrencies [] + +test :: IO () +test = runEmulatorTraceIO $ do + let tn = "ABC" + deadline = 10 + h <- activateContractWallet (Wallet 1) endpoints + callEndpoint @"mint" h $ MintParams + { mpTokenName = tn + , mpDeadline = deadline + , mpAmount = 555 + } + void $ Emulator.waitNSlots 15 + callEndpoint @"mint" h $ MintParams + { mpTokenName = tn + , mpDeadline = deadline + , mpAmount = 555 + } + void $ Emulator.waitNSlots 1 diff --git a/code/week05/src/Week05/Solution2.hs b/code/week05/src/Week05/Solution2.hs new file mode 100644 index 0000000..f97e98e --- /dev/null +++ b/code/week05/src/Week05/Solution2.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week05.Solution2 where + +import Control.Monad hiding (fmap) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +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 tn #-} +tn :: TokenName +tn = TokenName emptyByteString + +{-# INLINABLE mkPolicy #-} +mkPolicy :: TxOutRef -> ScriptContext -> Bool +mkPolicy oref 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 -> Scripts.MonetaryPolicy +policy oref = mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . mkPolicy ||]) + `PlutusTx.applyCode` + PlutusTx.liftCode oref + +curSymbol :: TxOutRef -> CurrencySymbol +curSymbol = scriptCurrencySymbol . policy + +type NFTSchema = + BlockchainActions + .\/ Endpoint "mint" () + +mint :: Contract w NFTSchema Text () +mint = 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 1 + lookups = Constraints.monetaryPolicy (policy oref) <> 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 + h1 <- activateContractWallet (Wallet 1) endpoints + h2 <- activateContractWallet (Wallet 2) endpoints + callEndpoint @"mint" h1 () + callEndpoint @"mint" h2 () + void $ Emulator.waitNSlots 1