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

small modifications

Browse source
This commit is contained in:
Lars Brünjes 2021-07-14 17:37:34 +02:00
parent 864e4073ce
commit 840d80a585
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
4 changed files with 28 additions and 113 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -10,8 +10,7 @@ License-files: LICENSE
library library
hs-source-dirs: src hs-source-dirs: src
exposed-modules: Week03.IsData exposed-modules: Week03.Homework1
, Week03.Homework1
, Week03.Homework2 , Week03.Homework2
, Week03.Parameterized , Week03.Parameterized
, Week03.Solution1 , Week03.Solution1
@ -20,6 +19,7 @@ library
build-depends: aeson build-depends: aeson
, base ^>=4.14.1.0 , base ^>=4.14.1.0
, containers , containers
, data-default
, playground-common , playground-common
, plutus-contract , plutus-contract
, plutus-ledger , plutus-ledger

90
code/week03/src/Week03/IsData.hs
View file

@ -1,90 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Week03.IsData where
import Control.Monad hiding (fmap)
import Data.Map as Map
import Data.Text (Text)
import Data.Void (Void)
import Plutus.Contract
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.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Prelude (IO, Semigroup (..), Show, String)
import Text.Printf (printf)
newtype MySillyRedeemer = MySillyRedeemer Integer
deriving Show
PlutusTx.unstableMakeIsData ''MySillyRedeemer
{-# INLINABLE mkValidator #-}
mkValidator :: () -> MySillyRedeemer -> ScriptContext -> Bool
mkValidator () (MySillyRedeemer r) _ = traceIfFalse "wrong redeemer" $ r == 42
data Typed
instance Scripts.ValidatorTypes Typed where
type instance DatumType Typed = ()
type instance RedeemerType Typed = MySillyRedeemer
typedValidator :: Scripts.TypedValidator Typed
typedValidator = Scripts.mkTypedValidator @Typed
$$(PlutusTx.compile [|| mkValidator ||])
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator @() @MySillyRedeemer
validator :: Validator
validator = Scripts.validatorScript typedValidator
scrAddress :: Ledger.Address
scrAddress = scriptAddress validator
type GiftSchema =
Endpoint "give" Integer
.\/ Endpoint "grab" Integer
give :: AsContractError e => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
ledgerTx <- submitTxConstraints typedValidator tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. AsContractError e => Integer -> Contract w s e ()
grab r = do
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData $ MySillyRedeemer r | oref <- orefs]
ledgerTx <- submitTxConstraintsWith @Void lookups tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ "collected gifts"
endpoints :: Contract () GiftSchema Text ()
endpoints = (give' `select` grab') >> endpoints
where
give' = endpoint @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

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

@ -11,6 +11,8 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Week03.Parameterized where module Week03.Parameterized where
import Control.Monad hiding (fmap) import Control.Monad hiding (fmap)
@ -20,6 +22,7 @@ import Data.Text (Text)
import Data.Void (Void) import Data.Void (Void)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Plutus.Contract import Plutus.Contract
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)
@ -32,45 +35,44 @@ import Playground.Types (KnownCurrency (..))
import Prelude (IO, Semigroup (..), Show (..), String) import Prelude (IO, Semigroup (..), Show (..), String)
import Text.Printf (printf) import Text.Printf (printf)
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
data VestingParam = VestingParam data VestingParam = VestingParam
{ beneficiary :: PubKeyHash { beneficiary :: PubKeyHash
, deadline :: POSIXTime , deadline :: POSIXTime
} deriving Show } deriving Show
PlutusTx.unstableMakeIsData ''VestingParam
PlutusTx.makeLift ''VestingParam PlutusTx.makeLift ''VestingParam
{-# INLINABLE mkValidator #-} {-# INLINABLE mkValidator #-}
mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool
mkValidator p () () ctx = mkValidator p () () ctx = traceIfFalse "beneficiary's signature missing" signedByBeneficiary &&
traceIfFalse "beneficiary's signature missing" checkSig && traceIfFalse "deadline not reached" deadlineReached
traceIfFalse "deadline not reached" checkDeadline
where where
info :: TxInfo info :: TxInfo
info = scriptContextTxInfo ctx info = scriptContextTxInfo ctx
checkSig :: Bool signedByBeneficiary :: Bool
checkSig = beneficiary p `elem` txInfoSignatories info signedByBeneficiary = txSignedBy info $ beneficiary p
checkDeadline :: Bool deadlineReached :: Bool
checkDeadline = from (deadline p) `contains` txInfoValidRange info deadlineReached = contains (from $ deadline p) $ txInfoValidRange info
data Vesting data Vesting
instance Scripts.ValidatorTypes Vesting where instance Scripts.ValidatorTypes Vesting where
type instance DatumType Vesting = () type instance DatumType Vesting = ()
type instance RedeemerType Vesting = () type instance RedeemerType Vesting = ()
inst :: VestingParam -> Scripts.TypedValidator Vesting typedValidator :: VestingParam -> Scripts.TypedValidator Vesting
inst p = Scripts.mkTypedValidator @Vesting typedValidator p = Scripts.mkTypedValidator @Vesting
($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p) ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p)
$$(PlutusTx.compile [|| wrap ||]) $$(PlutusTx.compile [|| wrap ||])
where where
wrap = Scripts.wrapValidator @() @() wrap = Scripts.wrapValidator @() @()
validator :: VestingParam -> Validator validator :: VestingParam -> Validator
validator = Scripts.validatorScript . inst validator = Scripts.validatorScript . typedValidator
valHash :: VestingParam -> Ledger.ValidatorHash
valHash = Scripts.validatorHash . typedValidator
scrAddress :: VestingParam -> Ledger.Address scrAddress :: VestingParam -> Ledger.Address
scrAddress = scriptAddress . validator scrAddress = scriptAddress . validator
@ -92,7 +94,7 @@ give gp = do
, deadline = gpDeadline gp , deadline = gpDeadline gp
} }
tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp
ledgerTx <- submitTxConstraints (inst p) tx ledgerTx <- submitTxConstraints (typedValidator p) tx
void $ awaitTxConfirmed $ txId ledgerTx void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s" logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s"
(gpAmount gp) (gpAmount gp)

17
code/week03/src/Week03/Vesting.hs
View file

@ -21,6 +21,7 @@ import Data.Text (Text)
import Data.Void (Void) import Data.Void (Void)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Plutus.Contract import Plutus.Contract
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)
@ -42,18 +43,17 @@ PlutusTx.unstableMakeIsData ''VestingDatum
{-# INLINABLE mkValidator #-} {-# INLINABLE mkValidator #-}
mkValidator :: VestingDatum -> () -> ScriptContext -> Bool mkValidator :: VestingDatum -> () -> ScriptContext -> Bool
mkValidator dat () ctx = mkValidator dat () ctx = traceIfFalse "beneficiary's signature missing" signedByBeneficiary &&
traceIfFalse "beneficiary's signature missing" checkSig && traceIfFalse "deadline not reached" deadlineReached
traceIfFalse "deadline not reached" checkDeadline
where where
info :: TxInfo info :: TxInfo
info = scriptContextTxInfo ctx info = scriptContextTxInfo ctx
checkSig :: Bool signedByBeneficiary :: Bool
checkSig = beneficiary dat `elem` txInfoSignatories info signedByBeneficiary = txSignedBy info $ beneficiary dat
checkDeadline :: Bool deadlineReached :: Bool
checkDeadline = from (deadline dat) `contains` txInfoValidRange info deadlineReached = contains (from $ deadline dat) $ txInfoValidRange info
data Vesting data Vesting
instance Scripts.ValidatorTypes Vesting where instance Scripts.ValidatorTypes Vesting where
@ -70,6 +70,9 @@ typedValidator = Scripts.mkTypedValidator @Vesting
validator :: Validator validator :: Validator
validator = Scripts.validatorScript typedValidator validator = Scripts.validatorScript typedValidator
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash typedValidator
scrAddress :: Ledger.Address scrAddress :: Ledger.Address
scrAddress = scriptAddress validator scrAddress = scriptAddress validator