From 63970a7edc2e6f88d2a1bf2f77719182d9f70b88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 20 Apr 2021 09:09:21 +0200 Subject: [PATCH] week 3 --- README.md | 13 ++ .../plutus-pioneer-program-week03.cabal | 2 + code/week03/src/Week03/Homework1.hs | 133 ++++++++++++++ code/week03/src/Week03/Homework2.hs | 111 ++++++++++++ code/week03/src/Week03/Parameterized.hs | 165 ++++++++++-------- 5 files changed, 351 insertions(+), 73 deletions(-) create mode 100644 code/week03/src/Week03/Homework1.hs create mode 100644 code/week03/src/Week03/Homework2.hs diff --git a/README.md b/README.md index 263a7ce..ca2d14a 100644 --- a/README.md +++ b/README.md @@ -15,10 +15,17 @@ - Low-level, untyped on-chain validation scripts. - High-level, typed on-chain validation scripts. +- [Lecture #3](https://youtu.be/Lk1eIVm_ZTQ) + + - Script context. + - Time handling. + - Parameterized contracts. + ## Code Examples - Lecture #1: [English Auction](code/week01) - Lecture #2: [Simple Validation](code/week02) +- Lecture #3: [Validation Context & Parameterized Contracts](code/week03) ## Exercises @@ -41,6 +48,12 @@ - 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. +- Week #3 + + - Fix and complete the code in the [Homework1](code/week03/src/Week02/Homework1.hs) module. + - Fix and complete the code in the [Homework2](code/week03/src/Week02/Homework2.hs) module. + + ## Solutions - Week #2 diff --git a/code/week03/plutus-pioneer-program-week03.cabal b/code/week03/plutus-pioneer-program-week03.cabal index 07639ed..28b6aec 100644 --- a/code/week03/plutus-pioneer-program-week03.cabal +++ b/code/week03/plutus-pioneer-program-week03.cabal @@ -11,6 +11,8 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week03.IsData + , Week03.Homework1 + , Week03.Homework2 , Week03.Parameterized , Week03.Vesting build-depends: aeson diff --git a/code/week03/src/Week03/Homework1.hs b/code/week03/src/Week03/Homework1.hs new file mode 100644 index 0000000..079a731 --- /dev/null +++ b/code/week03/src/Week03/Homework1.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week03.Homework1 where + +import Control.Monad hiding (fmap) +import Data.Aeson (ToJSON, FromJSON) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import Plutus.Contract hiding (when) +import qualified PlutusTx +import PlutusTx.Prelude hiding (unless) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +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 qualified Prelude as P +import Text.Printf (printf) + +data VestingDatum = VestingDatum + { beneficiary1 :: PubKeyHash + , beneficiary2 :: PubKeyHash + , deadline :: Slot + } deriving Show + +PlutusTx.unstableMakeIsData ''VestingDatum + +{-# INLINABLE mkValidator #-} +-- This should validate if either beneficiary1 has signed the transaction and the current slot is before or at the deadline +-- or if beneficiary2 has signed the transaction and the deadline has passed. +mkValidator :: VestingDatum -> () -> ScriptContext -> Bool +mkValidator _ _ _ = False -- FIX ME! + +data Vesting +instance Scripts.ScriptType Vesting where + type instance DatumType Vesting = VestingDatum + type instance RedeemerType Vesting = () + +inst :: Scripts.ScriptInstance Vesting +inst = Scripts.validator @Vesting + $$(PlutusTx.compile [|| mkValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @VestingDatum @() + +validator :: Validator +validator = Scripts.validatorScript inst + +scrAddress :: Ledger.Address +scrAddress = scriptAddress validator + +data GiveParams = GiveParams + { gpBeneficiary :: !PubKeyHash + , gpDeadline :: !Slot + , gpAmount :: !Integer + } deriving (Generic, ToJSON, FromJSON, ToSchema) + +type VestingSchema = + BlockchainActions + .\/ Endpoint "give" GiveParams + .\/ Endpoint "grab" () + +give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e () +give gp = do + pkh <- pubKeyHash <$> ownPubKey + let dat = VestingDatum + { beneficiary1 = gpBeneficiary gp + , beneficiary2 = pkh + , deadline = gpDeadline gp + } + tx = mustPayToTheScript dat $ Ada.lovelaceValueOf $ gpAmount gp + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" + (gpAmount gp) + (show $ gpBeneficiary gp) + (show $ gpDeadline gp) + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () +grab = do + now <- currentSlot + pkh <- pubKeyHash <$> ownPubKey + utxos <- utxoAt scrAddress + let utxos1 = Map.filter (isSuitable $ \dat -> beneficiary1 dat == pkh && now <= deadline dat) utxos + utxos2 = Map.filter (isSuitable $ \dat -> beneficiary2 dat == pkh && now > deadline dat) utxos + logInfo @String $ printf "found %d gift(s) to grab" (Map.size utxos1 P.+ Map.size utxos2) + unless (Map.null utxos1) $ do + let orefs = fst <$> Map.toList utxos1 + lookups = Constraints.unspentOutputs utxos1 P.<> + Constraints.otherScript validator + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<> + mustValidateIn (to now) + void $ submitTxConstraintsWith @Void lookups tx + unless (Map.null utxos2) $ do + let orefs = fst <$> Map.toList utxos2 + lookups = Constraints.unspentOutputs utxos2 P.<> + Constraints.otherScript validator + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<> + mustValidateIn (from now) + void $ submitTxConstraintsWith @Void lookups tx + where + isSuitable :: (VestingDatum -> Bool) -> TxOutTx -> Bool + isSuitable p o = case txOutDatumHash $ txOutTxOut o of + Nothing -> False + Just h -> case Map.lookup h $ txData $ txOutTxTx o of + Nothing -> False + Just (Datum e) -> maybe False p $ PlutusTx.fromData e + +endpoints :: Contract () VestingSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >> grab + +mkSchemaDefinitions ''VestingSchema + +mkKnownCurrencies [] diff --git a/code/week03/src/Week03/Homework2.hs b/code/week03/src/Week03/Homework2.hs new file mode 100644 index 0000000..3810835 --- /dev/null +++ b/code/week03/src/Week03/Homework2.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week03.Homework2 where + +import Control.Monad hiding (fmap) +import Data.Aeson (ToJSON, FromJSON) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import GHC.Generics (Generic) +import Plutus.Contract hiding (when) +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.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) + +{-# INLINABLE mkValidator #-} +mkValidator :: PubKeyHash -> Slot -> () -> ScriptContext -> Bool +mkValidator _ _ _ _ = False -- FIX ME! + +data Vesting +instance Scripts.ScriptType Vesting where + type instance DatumType Vesting = Slot + type instance RedeemerType Vesting = () + +inst :: PubKeyHash -> Scripts.ScriptInstance Vesting +inst = undefined -- IMPLEMENT ME! + +validator :: PubKeyHash -> Validator +validator = undefined -- IMPLEMENT ME! + +scrAddress :: PubKeyHash -> Ledger.Address +scrAddress = undefined -- IMPLEMENT ME! + +data GiveParams = GiveParams + { gpBeneficiary :: !PubKeyHash + , gpDeadline :: !Slot + , gpAmount :: !Integer + } deriving (Generic, ToJSON, FromJSON, ToSchema) + +type VestingSchema = + BlockchainActions + .\/ Endpoint "give" GiveParams + .\/ Endpoint "grab" () + +give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e () +give gp = do + let p = gpBeneficiary gp + d = gpDeadline gp + tx = mustPayToTheScript d $ Ada.lovelaceValueOf $ gpAmount gp + ledgerTx <- submitTxConstraints (inst p) tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" + (gpAmount gp) + (show $ gpBeneficiary gp) + (show $ gpDeadline gp) + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () +grab = do + now <- currentSlot + pkh <- pubKeyHash <$> ownPubKey + utxos <- Map.filter (isSuitable now) <$> utxoAt (scrAddress pkh) + if Map.null utxos + then logInfo @String $ "no gifts available" + else do + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript (validator pkh) + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] <> + mustValidateIn (from now) + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ "collected gifts" + where + isSuitable :: Slot -> TxOutTx -> Bool + isSuitable now o = case txOutDatumHash $ txOutTxOut o of + Nothing -> False + Just h -> case Map.lookup h $ txData $ txOutTxTx o of + Nothing -> False + Just (Datum e) -> case PlutusTx.fromData e of + Nothing -> False + Just d -> d <= now + +endpoints :: Contract () VestingSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >> grab + +mkSchemaDefinitions ''VestingSchema + +mkKnownCurrencies [] diff --git a/code/week03/src/Week03/Parameterized.hs b/code/week03/src/Week03/Parameterized.hs index 9fce376..19e64a8 100644 --- a/code/week03/src/Week03/Parameterized.hs +++ b/code/week03/src/Week03/Parameterized.hs @@ -1,27 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -module Week03.Parameterized - ( give - , grab - , ParameterizedSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) where +module Week03.Parameterized where import Control.Monad hiding (fmap) import Data.Aeson (ToJSON, FromJSON) @@ -30,86 +20,115 @@ 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.Typed.Scripts as Scripts import Ledger.Ada as Ada -import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage) +import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema) import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions) import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) -import Schema (ToSchema) import Text.Printf (printf) -{-# INLINABLE mkParameterizedValidator #-} -mkParameterizedValidator :: Integer -> () -> Integer -> ScriptContext -> Bool -mkParameterizedValidator r () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == r) +data VestingParam = VestingParam + { beneficiary :: PubKeyHash + , deadline :: Slot + } deriving Show -data Parameterizing -instance Scripts.ScriptType Parameterizing where - type instance RedeemerType Parameterizing = Integer - type instance DatumType Parameterizing = () +PlutusTx.unstableMakeIsData ''VestingParam +PlutusTx.makeLift ''VestingParam -parameterizedInstance :: Integer -> Scripts.ScriptInstance Parameterizing -parameterizedInstance r = Scripts.validator @Parameterizing - ($$(PlutusTx.compile [|| mkParameterizedValidator ||]) - `PlutusTx.applyCode` - PlutusTx.liftCode r) +{-# INLINABLE mkValidator #-} +mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool +mkValidator p () () ctx = + traceIfFalse "beneficiary's signature missing" checkSig && + traceIfFalse "deadline not reached" checkDeadline + where + info :: TxInfo + info = scriptContextTxInfo ctx + + checkSig :: Bool + checkSig = beneficiary p `elem` txInfoSignatories info + + checkDeadline :: Bool + checkDeadline = from (deadline p) `contains` txInfoValidRange info + +data Vesting +instance Scripts.ScriptType Vesting where + type instance DatumType Vesting = () + type instance RedeemerType Vesting = () + +inst :: VestingParam -> Scripts.ScriptInstance Vesting +inst p = Scripts.validator @Vesting + ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p) $$(PlutusTx.compile [|| wrap ||]) where - wrap = Scripts.wrapValidator @() @Integer + wrap = Scripts.wrapValidator @() @() -parameterizedValidator :: Integer -> Validator -parameterizedValidator = Scripts.validatorScript . parameterizedInstance +validator :: VestingParam -> Validator +validator = Scripts.validatorScript . inst -parameterizedAddress :: Integer -> Ledger.Address -parameterizedAddress = scriptAddress . parameterizedValidator - -type ParameterizedSchema = - BlockchainActions - .\/ Endpoint "give" GiveParams - .\/ Endpoint "grab" GrabParams +scrAddress :: VestingParam -> Ledger.Address +scrAddress = scriptAddress . validator data GiveParams = GiveParams - { giveAmount :: Integer - , giveParameter :: Integer + { gpBeneficiary :: !PubKeyHash + , gpDeadline :: !Slot + , gpAmount :: !Integer } deriving (Generic, ToJSON, FromJSON, ToSchema) -data GrabParams = GrabParams - { grabParameter :: Integer - , grabRedeemer :: Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) +type VestingSchema = + BlockchainActions + .\/ Endpoint "give" GiveParams + .\/ Endpoint "grab" Slot give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e () -give p = do - let amount = giveAmount p - let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount - ledgerTx <- submitTxConstraints (parameterizedInstance $ giveParameter p) tx +give gp = do + let p = VestingParam + { beneficiary = gpBeneficiary gp + , deadline = gpDeadline gp + } + tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp + ledgerTx <- submitTxConstraints (inst p) tx void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "made a gift of %d lovelace" amount + logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" + (gpAmount gp) + (show $ gpBeneficiary gp) + (show $ gpDeadline gp) -grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => GrabParams -> Contract w s e () -grab p = do - let par = grabParameter p - utxos <- utxoAt $ parameterizedAddress par - let orefs = fst <$> Map.toList utxos - lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript (parameterizedValidator par) - tx :: TxConstraints Void Void - tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I $ grabRedeemer p | oref <- orefs] - ledgerTx <- submitTxConstraintsWith @Void lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ "collected gifts" +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Slot -> Contract w s e () +grab d = do + now <- currentSlot + pkh <- pubKeyHash <$> ownPubKey + if now < d + then logInfo @String $ "too early" + else do + let p = VestingParam + { beneficiary = pkh + , deadline = d + } + utxos <- utxoAt $ scrAddress p + if Map.null utxos + then logInfo @String $ "no gifts available" + else do + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript (validator p) + tx :: TxConstraints Void Void + tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] <> + mustValidateIn (from now) + ledgerTx <- submitTxConstraintsWith @Void lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ "collected gifts" -endpoints :: Contract () ParameterizedSchema Text () +endpoints :: Contract () VestingSchema Text () endpoints = (give' `select` grab') >> endpoints where give' = endpoint @"give" >>= give grab' = endpoint @"grab" >>= grab -mkSchemaDefinitions ''ParameterizedSchema +mkSchemaDefinitions ''VestingSchema mkKnownCurrencies []