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

View file

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

View file

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

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

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

View file

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