code for week 4

This commit is contained in:
Lars Brünjes 2021-04-27 09:14:58 +02:00
parent 7ea86f3d98
commit 83d437c32e
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
11 changed files with 382 additions and 18 deletions

View file

@ -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.

View file

@ -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

View 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

View file

@ -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)

View 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

View file

@ -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)

View 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

View file

@ -1,2 +0,0 @@
module Week04.State where

View file

@ -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

View 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

View 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