From e05f1900ff815a48f8b20d26e99c3fcd864c51a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 14 Apr 2021 16:42:16 +0200 Subject: [PATCH] added solutions for week 2 --- README.md | 7 ++ .../plutus-pioneer-program-week02.cabal | 2 + code/week02/src/Week02/Solution1.hs | 90 ++++++++++++++++ code/week02/src/Week02/Solution2.hs | 101 ++++++++++++++++++ 4 files changed, 200 insertions(+) create mode 100644 code/week02/src/Week02/Solution1.hs create mode 100644 code/week02/src/Week02/Solution2.hs diff --git a/README.md b/README.md index 25be432..dc3f3e1 100644 --- a/README.md +++ b/README.md @@ -41,6 +41,13 @@ - Fix and complete the code in the [Homework1](code/week02/src/Week02/Homework1.hs) module. - Fix and complete the code in the [Homework2](code/week02/src/Week02/Homework2.hs) module. +## Solutions + +- Week #2 + + - [`Homework1`](code/week02/src/Week02/Solution1.hs) + - [`Homework2`](code/week02/src/Week02/Solution2.hs) + ## Some Plutus Modules - [`PlutusTx.Data`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/Data.hs), contains the definition of the `Data` type. diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index d88f361..d60115b 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -16,6 +16,8 @@ library , Week02.Homework2 , Week02.Gift , Week02.IsData + , Week02.Solution1 + , Week02.Solution2 , Week02.Typed build-depends: aeson , base ^>=4.14.1.0 diff --git a/code/week02/src/Week02/Solution1.hs b/code/week02/src/Week02/Solution1.hs new file mode 100644 index 0000000..5031a0d --- /dev/null +++ b/code/week02/src/Week02/Solution1.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Solution1 where + +import Control.Monad hiding (fmap) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import Plutus.Contract hiding (when) +import PlutusTx (Data (..)) +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), unless) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Ada as Ada +import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage) +import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) +import Playground.Types (KnownCurrency (..)) +import Prelude (Semigroup (..)) +import Text.Printf (printf) + +{-# INLINABLE mkValidator #-} +-- This should validate if and only if the two Booleans in the redeemer are equal! +mkValidator :: () -> (Bool, Bool) -> ValidatorCtx -> Bool +mkValidator () (b, c) _ = traceIfFalse "wrong redeemer" $ b == c + +data Typed +instance Scripts.ScriptType Typed where + type instance DatumType Typed = () + type instance RedeemerType Typed = (Bool, Bool) + +inst :: Scripts.ScriptInstance Typed +inst = Scripts.validator @Typed + $$(PlutusTx.compile [|| mkValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @() @(Bool, Bool) + +validator :: Validator +validator = Scripts.validatorScript inst + +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator + +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" (Bool, Bool) + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => (Bool, Bool) -> Contract w s e () +grab bs = do + utxos <- utxoAt scrAddress + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript validator + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData bs | oref <- orefs] + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ "collected gifts" + +endpoints :: Contract () GiftSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >>= grab + +mkSchemaDefinitions ''GiftSchema + +mkKnownCurrencies [] diff --git a/code/week02/src/Week02/Solution2.hs b/code/week02/src/Week02/Solution2.hs new file mode 100644 index 0000000..006a6a4 --- /dev/null +++ b/code/week02/src/Week02/Solution2.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Solution2 where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import Plutus.Contract hiding (when) +import PlutusTx (Data (..)) +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup(..), unless) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Ada as Ada +import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema) +import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) +import Playground.Types (KnownCurrency (..)) +import Prelude (Semigroup (..)) +import Text.Printf (printf) + +data MyRedeemer = MyRedeemer + { flag1 :: Bool + , flag2 :: Bool + } deriving (Generic, FromJSON, ToJSON, ToSchema) + +PlutusTx.unstableMakeIsData ''MyRedeemer + +{-# INLINABLE mkValidator #-} +-- This should validate if and only if the two Booleans in the redeemer are equal! +mkValidator :: () -> MyRedeemer -> ValidatorCtx -> Bool +mkValidator () (MyRedeemer b c) _ = traceIfFalse "wrong redeemer" $ b == c + +data Typed +instance Scripts.ScriptType Typed where + type instance DatumType Typed = () + type instance RedeemerType Typed = MyRedeemer + +inst :: Scripts.ScriptInstance Typed +inst = Scripts.validator @Typed + $$(PlutusTx.compile [|| mkValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @() @MyRedeemer + +validator :: Validator +validator = Scripts.validatorScript inst + +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator + +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" MyRedeemer + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => MyRedeemer -> Contract w s e () +grab r = do + utxos <- utxoAt scrAddress + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript validator + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData r | oref <- orefs] + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ "collected gifts" + +endpoints :: Contract () GiftSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >>= grab + +mkSchemaDefinitions ''GiftSchema + +mkKnownCurrencies []