sample solutions for week 5

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

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

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