claudiomaradonna/plutus-pioneer-program
1
0
Fork 0
mirror of https://github.com/FiloSpaTeam/plutus-pioneer-program.git synced 2024-11-14 10:52:35 +01:00
Code Issues Projects Releases Packages Wiki Activity

week 3

Browse source
This commit is contained in:
Lars Brünjes 2021-04-20 09:09:21 +02:00
parent 234e2a205a
commit 63970a7edc
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
5 changed files with 351 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
README.md
View file

@ -15,10 +15,17 @@
- Low-level, untyped on-chain validation scripts. - Low-level, untyped on-chain validation scripts.
- High-level, typed 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 ## Code Examples
- Lecture #1: [English Auction](code/week01) - Lecture #1: [English Auction](code/week01)
- Lecture #2: [Simple Validation](code/week02) - Lecture #2: [Simple Validation](code/week02)
- Lecture #3: [Validation Context & Parameterized Contracts](code/week03)
## Exercises ## 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 [Homework1](code/week02/src/Week02/Homework1.hs) module.
- Fix and complete the code in the [Homework2](code/week02/src/Week02/Homework2.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 ## Solutions
- Week #2 - Week #2

2
code/week03/plutus-pioneer-program-week03.cabal
View file

@ -11,6 +11,8 @@ License-files: LICENSE
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: Week03.IsData exposed-modules: Week03.IsData
, Week03.Homework1
, Week03.Homework2
, Week03.Parameterized , Week03.Parameterized
, Week03.Vesting , Week03.Vesting
build-depends: aeson build-depends: aeson

133
code/week03/src/Week03/Homework1.hs Normal file
View file

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

111
code/week03/src/Week03/Homework2.hs Normal file
View file

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

165
code/week03/src/Week03/Parameterized.hs
View file

@ -1,27 +1,17 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week03.Parameterized module Week03.Parameterized where
( give
, grab
, ParameterizedSchema
, endpoints
, schemas
, registeredKnownCurrencies
, printJson
, printSchemas
, ensureKnownCurrencies
, stage
) where
import Control.Monad hiding (fmap) import Control.Monad hiding (fmap)
import Data.Aeson (ToJSON, FromJSON) import Data.Aeson (ToJSON, FromJSON)
@ -30,86 +20,115 @@ import Data.Text (Text)
import Data.Void (Void) import Data.Void (Void)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Plutus.Contract hiding (when) import Plutus.Contract hiding (when)
import PlutusTx (Data (..))
import qualified PlutusTx import qualified PlutusTx
import PlutusTx.Prelude hiding (Semigroup(..), unless) import PlutusTx.Prelude hiding (Semigroup(..), unless)
import Ledger hiding (singleton) import Ledger hiding (singleton)
import Ledger.Constraints as Constraints import Ledger.Constraints as Constraints
import qualified Ledger.Typed.Scripts as Scripts import qualified Ledger.Typed.Scripts as Scripts
import Ledger.Ada as Ada 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.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..)) import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..)) import Prelude (Semigroup (..))
import Schema (ToSchema)
import Text.Printf (printf) import Text.Printf (printf)
{-# INLINABLE mkParameterizedValidator #-} data VestingParam = VestingParam
mkParameterizedValidator :: Integer -> () -> Integer -> ScriptContext -> Bool { beneficiary :: PubKeyHash
mkParameterizedValidator r () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == r) , deadline :: Slot
} deriving Show
data Parameterizing PlutusTx.unstableMakeIsData ''VestingParam
instance Scripts.ScriptType Parameterizing where PlutusTx.makeLift ''VestingParam
type instance RedeemerType Parameterizing = Integer
type instance DatumType Parameterizing = ()
parameterizedInstance :: Integer -> Scripts.ScriptInstance Parameterizing {-# INLINABLE mkValidator #-}
parameterizedInstance r = Scripts.validator @Parameterizing mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool
($$(PlutusTx.compile [|| mkParameterizedValidator ||]) mkValidator p () () ctx =
`PlutusTx.applyCode` traceIfFalse "beneficiary's signature missing" checkSig &&
PlutusTx.liftCode r) 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 ||]) $$(PlutusTx.compile [|| wrap ||])
where where
wrap = Scripts.wrapValidator @() @Integer wrap = Scripts.wrapValidator @() @()
parameterizedValidator :: Integer -> Validator validator :: VestingParam -> Validator
parameterizedValidator = Scripts.validatorScript . parameterizedInstance validator = Scripts.validatorScript . inst
parameterizedAddress :: Integer -> Ledger.Address scrAddress :: VestingParam -> Ledger.Address
parameterizedAddress = scriptAddress . parameterizedValidator scrAddress = scriptAddress . validator
type ParameterizedSchema =
BlockchainActions
.\/ Endpoint "give" GiveParams
.\/ Endpoint "grab" GrabParams
data GiveParams = GiveParams data GiveParams = GiveParams
{ giveAmount :: Integer { gpBeneficiary :: !PubKeyHash
, giveParameter :: Integer , gpDeadline :: !Slot
, gpAmount :: !Integer
} deriving (Generic, ToJSON, FromJSON, ToSchema) } deriving (Generic, ToJSON, FromJSON, ToSchema)
data GrabParams = GrabParams type VestingSchema =
{ grabParameter :: Integer BlockchainActions
, grabRedeemer :: Integer .\/ Endpoint "give" GiveParams
} deriving (Generic, ToJSON, FromJSON, ToSchema) .\/ Endpoint "grab" Slot
give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e () give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e ()
give p = do give gp = do
let amount = giveAmount p let p = VestingParam
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount { beneficiary = gpBeneficiary gp
ledgerTx <- submitTxConstraints (parameterizedInstance $ giveParameter p) tx , deadline = gpDeadline gp
}
tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp
ledgerTx <- submitTxConstraints (inst p) tx
void $ awaitTxConfirmed $ txId ledgerTx 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 :: forall w s e. (HasBlockchainActions s, AsContractError e) => Slot -> Contract w s e ()
grab p = do grab d = do
let par = grabParameter p now <- currentSlot
utxos <- utxoAt $ parameterizedAddress par pkh <- pubKeyHash <$> ownPubKey
let orefs = fst <$> Map.toList utxos if now < d
lookups = Constraints.unspentOutputs utxos <> then logInfo @String $ "too early"
Constraints.otherScript (parameterizedValidator par) else do
tx :: TxConstraints Void Void let p = VestingParam
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I $ grabRedeemer p | oref <- orefs] { beneficiary = pkh
ledgerTx <- submitTxConstraintsWith @Void lookups tx , deadline = d
void $ awaitTxConfirmed $ txId ledgerTx }
logInfo @String $ "collected gifts" 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 endpoints = (give' `select` grab') >> endpoints
where where
give' = endpoint @"give" >>= give give' = endpoint @"give" >>= give
grab' = endpoint @"grab" >>= grab grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''ParameterizedSchema mkSchemaDefinitions ''VestingSchema
mkKnownCurrencies [] mkKnownCurrencies []