From 83d437c32e56711f0d5091631a5b610b97973566 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Tue, 27 Apr 2021 09:14:58 +0200 Subject: [PATCH] code for week 4 --- README.md | 12 ++ .../plutus-pioneer-program-week04.cabal | 7 +- code/week04/src/Week04/Contract.hs | 81 +++++++++++ code/week04/src/Week04/Either.hs | 4 + code/week04/src/Week04/Homework.hs | 45 ++++++ code/week04/src/Week04/Maybe.hs | 4 + code/week04/src/Week04/Monad.hs | 26 ++++ code/week04/src/Week04/State.hs | 2 - code/week04/src/Week04/Trace.hs | 34 +++-- code/week04/src/Week04/Vesting.hs | 132 ++++++++++++++++++ code/week04/src/Week04/Writer.hs | 53 +++++++ 11 files changed, 382 insertions(+), 18 deletions(-) create mode 100644 code/week04/src/Week04/Contract.hs create mode 100644 code/week04/src/Week04/Homework.hs create mode 100644 code/week04/src/Week04/Monad.hs delete mode 100644 code/week04/src/Week04/State.hs create mode 100644 code/week04/src/Week04/Vesting.hs create mode 100644 code/week04/src/Week04/Writer.hs diff --git a/README.md b/README.md index d133cd2..ffd2404 100644 --- a/README.md +++ b/README.md @@ -21,11 +21,18 @@ - Time handling. - Parameterized contracts. +- [Lecture #4](https://youtu.be/6Reuh0xZDjY) + + - Monads + - The `EmulatorTrace` monad. + - The `Contract` monad. + ## Code Examples - Lecture #1: [English Auction](code/week01) - Lecture #2: [Simple Validation](code/week02) - Lecture #3: [Validation Context & Parameterized Contracts](code/week03) +- Lecture #4: [Monads, `EmulatorTrace` & `Contract`](code/week04) ## Exercises @@ -53,6 +60,10 @@ - Fix and complete the code in the [Homework1](code/week03/src/Week03/Homework1.hs) module. - Fix and complete the code in the [Homework2](code/week03/src/Week03/Homework2.hs) module. +- Week #4 + + - Write an appropriate `EmulatorTrace` that uses the `payContract` contract in the [Homework](code/week04/src/Week04/Homework.hs) module. + - Catch errors in the `payContract` contract in the same module. ## Solutions @@ -68,6 +79,7 @@ ## Some Plutus Modules +- [`Plutus.Trace.Emulator`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Trace/Emulator.hs), contains types and functions related to traces. - [`Plutus.V1.Ledger.Contexts`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Contexts.hs), contains the definition of the context-related types. - [`Plutus.V1.Ledger.Interval`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Interval.hs), contains the definition of and helper functions for the `Interval` type. - [`Plutus.V1.Ledger.Slot`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Slot.hs), contains the definition of the `Slot` type. diff --git a/code/week04/plutus-pioneer-program-week04.cabal b/code/week04/plutus-pioneer-program-week04.cabal index ab7f35d..692cd49 100644 --- a/code/week04/plutus-pioneer-program-week04.cabal +++ b/code/week04/plutus-pioneer-program-week04.cabal @@ -10,10 +10,13 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week04.Either + exposed-modules: Week04.Contract + , Week04.Either + , Week04.Homework , Week04.Maybe - , Week04.State + , Week04.Monad , Week04.Trace + , Week04.Writer build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week04/src/Week04/Contract.hs b/code/week04/src/Week04/Contract.hs new file mode 100644 index 0000000..51bb876 --- /dev/null +++ b/code/week04/src/Week04/Contract.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Week04.Contract where + +import Control.Monad.Freer.Extras as Extras +import Data.Functor (void) +import Data.Text (Text, unpack) +import Data.Void (Void) +import Plutus.Contract as Contract +import Plutus.Trace.Emulator as Emulator +import Wallet.Emulator.Wallet + +-- Contract w s e a +-- EmulatorTrace a + +myContract1 :: Contract () BlockchainActions Text () +myContract1 = do + void $ Contract.throwError "BOOM!" + Contract.logInfo @String "Hello from the contract!" + +myTrace1 :: EmulatorTrace () +myTrace1 = void $ activateContractWallet (Wallet 1) myContract1 + +test1 :: IO () +test1 = runEmulatorTraceIO myTrace1 + +myContract2 :: Contract () BlockchainActions Void () +myContract2 = Contract.handleError + (\err -> Contract.logError $ "Caught error: " ++ unpack err) + myContract1 + +myTrace2 :: EmulatorTrace () +myTrace2 = void $ activateContractWallet (Wallet 1) myContract2 + +test2 :: IO () +test2 = runEmulatorTraceIO myTrace2 + +type MySchema = BlockchainActions .\/ Endpoint "foo" Int + +myContract3 :: Contract () MySchema Text () +myContract3 = do + n <- endpoint @"foo" + Contract.logInfo n + +myTrace3 :: EmulatorTrace () +myTrace3 = do + h <- activateContractWallet (Wallet 1) myContract3 + callEndpoint @"foo" h 42 + +test3 :: IO () +test3 = runEmulatorTraceIO myTrace3 + +myContract4 :: Contract [Int] BlockchainActions Text () +myContract4 = do + void $ Contract.waitNSlots 10 + tell [1] + void $ Contract.waitNSlots 10 + tell [2] + void $ Contract.waitNSlots 10 + +myTrace4 :: EmulatorTrace () +myTrace4 = do + h <- activateContractWallet (Wallet 1) myContract4 + + void $ Emulator.waitNSlots 5 + xs <- observableState h + Extras.logInfo $ show xs + + void $ Emulator.waitNSlots 10 + ys <- observableState h + Extras.logInfo $ show ys + + void $ Emulator.waitNSlots 10 + zs <- observableState h + Extras.logInfo $ show zs + +test4 :: IO () +test4 = runEmulatorTraceIO myTrace4 diff --git a/code/week04/src/Week04/Either.hs b/code/week04/src/Week04/Either.hs index f05af36..39d7b7a 100644 --- a/code/week04/src/Week04/Either.hs +++ b/code/week04/src/Week04/Either.hs @@ -1,6 +1,7 @@ module Week04.Either where import Text.Read (readMaybe) +import Week04.Monad readEither :: Read a => String -> Either String a readEither s = case readMaybe s of @@ -25,3 +26,6 @@ foo' x y z = readEither x `bindEither` \k -> readEither y `bindEither` \l -> readEither z `bindEither` \m -> Right (k + l + m) + +foo'' :: String -> String -> String -> Either String Int +foo'' x y z = threeInts (readEither x) (readEither y) (readEither z) diff --git a/code/week04/src/Week04/Homework.hs b/code/week04/src/Week04/Homework.hs new file mode 100644 index 0000000..dac7ebd --- /dev/null +++ b/code/week04/src/Week04/Homework.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module Week04.Homework where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Functor (void) +import Data.Text (Text, unpack) +import GHC.Generics (Generic) +import Ledger +import Ledger.Ada as Ada +import Ledger.Constraints as Constraints +import Plutus.Contract as Contract +import Plutus.Trace.Emulator as Emulator +import Wallet.Emulator.Wallet + +data PayParams = PayParams + { ppRecipient :: PubKeyHash + , ppLovelace :: Integer + } deriving (Show, Generic, FromJSON, ToJSON) + +type PaySchema = BlockchainActions .\/ Endpoint "pay" PayParams + +payContract :: Contract () PaySchema Text () +payContract = do + pp <- endpoint @"pay" + let tx = mustPayToPubKey (ppRecipient pp) $ lovelaceValueOf $ ppLovelace pp + void $ submitTx tx + payContract + +-- A trace that invokes the pay endpoint of payContract on Wallet 1 twice, each time with Wallet 2 as +-- recipient, but with amounts given by the two arguments. There should be a delay of one slot +-- after each endpoint call. +payTrace :: Integer -> Integer -> EmulatorTrace () +payTrace x y = undefined -- IMPLEMENT ME! + +payTest1 :: IO () +payTest1 = runEmulatorTraceIO $ payTrace 1000000 2000000 + +payTest2 :: IO () +payTest2 = runEmulatorTraceIO $ payTrace 1000000000 2000000 diff --git a/code/week04/src/Week04/Maybe.hs b/code/week04/src/Week04/Maybe.hs index b5f4dd6..f7e9ec5 100644 --- a/code/week04/src/Week04/Maybe.hs +++ b/code/week04/src/Week04/Maybe.hs @@ -1,6 +1,7 @@ module Week04.Maybe where import Text.Read (readMaybe) +import Week04.Monad foo :: String -> String -> String -> Maybe Int foo x y z = case readMaybe x of @@ -20,3 +21,6 @@ foo' x y z = readMaybe x `bindMaybe` \k -> readMaybe y `bindMaybe` \l -> readMaybe z `bindMaybe` \m -> Just (k + l + m) + +foo'' :: String -> String -> String -> Maybe Int +foo'' x y z = threeInts (readMaybe x) (readMaybe y) (readMaybe z) diff --git a/code/week04/src/Week04/Monad.hs b/code/week04/src/Week04/Monad.hs new file mode 100644 index 0000000..2a54dba --- /dev/null +++ b/code/week04/src/Week04/Monad.hs @@ -0,0 +1,26 @@ +module Week04.Monad where + +-- (>>=) :: IO a -> (a -> IO b) -> IO b +-- bindMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b +-- bindEither :: Either String a -> (a -> Either String b) -> Either String b +-- bindWriter :: Writer a -> (a -> Writer b) -> Writer b +-- +-- return :: a -> IO a +-- Just :: a -> Maybe a +-- Right :: a -> Either String a +-- (\a -> Writer a []) :: a -> Writer a + +threeInts :: Monad m => m Int -> m Int -> m Int -> m Int +threeInts mx my mz = + mx >>= \k -> + my >>= \l -> + mz >>= \m -> + let s = k + l + m in return s + +threeInts' :: Monad m => m Int -> m Int -> m Int -> m Int +threeInts' mx my mz = do + k <- mx + l <- my + m <- mz + let s = k + l + m + return s diff --git a/code/week04/src/Week04/State.hs b/code/week04/src/Week04/State.hs deleted file mode 100644 index 54e10ce..0000000 --- a/code/week04/src/Week04/State.hs +++ /dev/null @@ -1,2 +0,0 @@ -module Week04.State where - diff --git a/code/week04/src/Week04/Trace.hs b/code/week04/src/Week04/Trace.hs index e405510..220a4f4 100644 --- a/code/week04/src/Week04/Trace.hs +++ b/code/week04/src/Week04/Trace.hs @@ -1,26 +1,32 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} + module Week04.Trace where import Control.Monad.Freer.Extras as Extras import Data.Functor (void) -import Data.Text (Text) -import Plutus.Contract as Contract +import Ledger import Plutus.Trace.Emulator as Emulator import Wallet.Emulator.Wallet +import Week04.Vesting + +-- Contract w s e a +-- EmulatorTrace a + test :: IO () test = runEmulatorTraceIO myTrace myTrace :: EmulatorTrace () myTrace = do - h <- activateContractWallet (Wallet 1) myContract - void $ Emulator.waitNSlots 1 - xs <- Emulator.observableState h - Extras.logInfo $ show xs - - -myContract :: Contract [Int] BlockchainActions Text () -myContract = do - Contract.logInfo "logging..." - tell [1] - void $ Contract.waitNSlots 10 - myContract + h1 <- activateContractWallet (Wallet 1) endpoints + h2 <- activateContractWallet (Wallet 2) endpoints + callEndpoint @"give" h1 $ GiveParams + { gpBeneficiary = pubKeyHash $ walletPubKey $ Wallet 2 + , gpDeadline = Slot 20 + , gpAmount = 1000 + } + void $ waitUntilSlot 20 + callEndpoint @"grab" h2 () + s <- waitNSlots 1 + Extras.logInfo $ "reached slot " ++ show s diff --git a/code/week04/src/Week04/Vesting.hs b/code/week04/src/Week04/Vesting.hs new file mode 100644 index 0000000..2e8761b --- /dev/null +++ b/code/week04/src/Week04/Vesting.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week04.Vesting + ( GiveParams (..) + , VestingSchema + , endpoints + ) 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 (ToSchema) +import Prelude (Semigroup (..)) +import Text.Printf (printf) + +data VestingDatum = VestingDatum + { beneficiary :: PubKeyHash + , deadline :: Slot + } deriving Show + +PlutusTx.unstableMakeIsData ''VestingDatum + +{-# INLINABLE mkValidator #-} +mkValidator :: VestingDatum -> () -> ScriptContext -> Bool +mkValidator dat () ctx = + traceIfFalse "beneficiary's signature missing" checkSig && + traceIfFalse "deadline not reached" checkDeadline + where + info :: TxInfo + info = scriptContextTxInfo ctx + + checkSig :: Bool + checkSig = beneficiary dat `elem` txInfoSignatories info + + checkDeadline :: Bool + checkDeadline = from (deadline dat) `contains` txInfoValidRange info + +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 + let dat = VestingDatum + { beneficiary = gpBeneficiary gp + , 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 <- Map.filter (isSuitable pkh now) <$> utxoAt scrAddress + 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 + 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 :: PubKeyHash -> Slot -> TxOutTx -> Bool + isSuitable pkh 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 -> beneficiary d == pkh && deadline d <= now + +endpoints :: Contract () VestingSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >> grab diff --git a/code/week04/src/Week04/Writer.hs b/code/week04/src/Week04/Writer.hs new file mode 100644 index 0000000..ba0e0c5 --- /dev/null +++ b/code/week04/src/Week04/Writer.hs @@ -0,0 +1,53 @@ +module Week04.Writer where + +import Control.Monad +import Week04.Monad + +data Writer a = Writer a [String] + deriving Show + +number :: Int -> Writer Int +number n = Writer n $ ["number: " ++ show n] + +tell :: [String] -> Writer () +tell = Writer () + +foo :: Writer Int -> Writer Int -> Writer Int -> Writer Int +foo (Writer k xs) (Writer l ys) (Writer m zs) = + let + s = k + l + m + Writer _ us = tell ["sum: " ++ show s] + in + Writer s $ xs ++ ys ++ zs ++ us + +bindWriter :: Writer a -> (a -> Writer b) -> Writer b +bindWriter (Writer a xs) f = + let + Writer b ys = f a + in + Writer b $ xs ++ ys + +foo' :: Writer Int -> Writer Int -> Writer Int -> Writer Int +foo' x y z = x `bindWriter` \k -> + y `bindWriter` \l -> + z `bindWriter` \m -> + let s = k + l + m + in tell ["sum: " ++ show s] `bindWriter` \_ -> + Writer s [] + +foo'' :: Writer Int -> Writer Int -> Writer Int -> Writer Int +foo'' x y z = do + s <- threeInts x y z + tell ["sum: " ++ show s] + return s + +instance Functor Writer where + fmap = liftM + +instance Applicative Writer where + pure = return + (<*>) = ap + +instance Monad Writer where + return a = Writer a [] + (>>=) = bindWriter