mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 02:42:35 +01:00
code for week 4
This commit is contained in:
parent
7ea86f3d98
commit
83d437c32e
11 changed files with 382 additions and 18 deletions
12
README.md
12
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.
|
||||
|
|
|
@ -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
|
||||
|
|
81
code/week04/src/Week04/Contract.hs
Normal file
81
code/week04/src/Week04/Contract.hs
Normal file
|
@ -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
|
|
@ -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)
|
||||
|
|
45
code/week04/src/Week04/Homework.hs
Normal file
45
code/week04/src/Week04/Homework.hs
Normal file
|
@ -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
|
|
@ -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)
|
||||
|
|
26
code/week04/src/Week04/Monad.hs
Normal file
26
code/week04/src/Week04/Monad.hs
Normal file
|
@ -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
|
|
@ -1,2 +0,0 @@
|
|||
module Week04.State where
|
||||
|
|
@ -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
|
||||
|
|
132
code/week04/src/Week04/Vesting.hs
Normal file
132
code/week04/src/Week04/Vesting.hs
Normal file
|
@ -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
|
53
code/week04/src/Week04/Writer.hs
Normal file
53
code/week04/src/Week04/Writer.hs
Normal file
|
@ -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
|
Loading…
Reference in a new issue