mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 05:21:59 +01:00
small modifications
This commit is contained in:
Lars Brünjes
parent
864e4073ce
commit
840d80a585
4 changed files with 28 additions and 113 deletions
|
|
@ -10,8 +10,7 @@ License-files: LICENSE
|
|||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Week03.IsData
|
||||
, Week03.Homework1
|
||||
exposed-modules: Week03.Homework1
|
||||
, Week03.Homework2
|
||||
, Week03.Parameterized
|
||||
, Week03.Solution1
|
||||
|
|
@ -20,6 +19,7 @@ library
|
|||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
, data-default
|
||||
, playground-common
|
||||
, plutus-contract
|
||||
, plutus-ledger
|
||||
|
|
|
|||
|
|
@ -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 []
|
||||
|
|
@ -11,6 +11,8 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
|
||||
module Week03.Parameterized where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
|
|
@ -20,6 +22,7 @@ import Data.Text (Text)
|
|||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract
|
||||
import PlutusTx (Data (..))
|
||||
import qualified PlutusTx
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Ledger hiding (singleton)
|
||||
|
|
@ -32,45 +35,44 @@ import Playground.Types (KnownCurrency (..))
|
|||
import Prelude (IO, Semigroup (..), Show (..), String)
|
||||
import Text.Printf (printf)
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||
|
||||
data VestingParam = VestingParam
|
||||
{ beneficiary :: PubKeyHash
|
||||
, deadline :: POSIXTime
|
||||
} deriving Show
|
||||
|
||||
PlutusTx.unstableMakeIsData ''VestingParam
|
||||
PlutusTx.makeLift ''VestingParam
|
||||
|
||||
{-# INLINABLE mkValidator #-}
|
||||
mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool
|
||||
mkValidator p () () ctx =
|
||||
traceIfFalse "beneficiary's signature missing" checkSig &&
|
||||
traceIfFalse "deadline not reached" checkDeadline
|
||||
mkValidator p () () ctx = traceIfFalse "beneficiary's signature missing" signedByBeneficiary &&
|
||||
traceIfFalse "deadline not reached" deadlineReached
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
checkSig :: Bool
|
||||
checkSig = beneficiary p `elem` txInfoSignatories info
|
||||
signedByBeneficiary :: Bool
|
||||
signedByBeneficiary = txSignedBy info $ beneficiary p
|
||||
|
||||
checkDeadline :: Bool
|
||||
checkDeadline = from (deadline p) `contains` txInfoValidRange info
|
||||
deadlineReached :: Bool
|
||||
deadlineReached = contains (from $ deadline p) $ txInfoValidRange info
|
||||
|
||||
data Vesting
|
||||
instance Scripts.ValidatorTypes Vesting where
|
||||
type instance DatumType Vesting = ()
|
||||
type instance RedeemerType Vesting = ()
|
||||
|
||||
inst :: VestingParam -> Scripts.TypedValidator Vesting
|
||||
inst p = Scripts.mkTypedValidator @Vesting
|
||||
typedValidator :: VestingParam -> Scripts.TypedValidator Vesting
|
||||
typedValidator p = Scripts.mkTypedValidator @Vesting
|
||||
($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p)
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @() @()
|
||||
|
||||
validator :: VestingParam -> Validator
|
||||
validator = Scripts.validatorScript . inst
|
||||
validator = Scripts.validatorScript . typedValidator
|
||||
|
||||
valHash :: VestingParam -> Ledger.ValidatorHash
|
||||
valHash = Scripts.validatorHash . typedValidator
|
||||
|
||||
scrAddress :: VestingParam -> Ledger.Address
|
||||
scrAddress = scriptAddress . validator
|
||||
|
|
@ -92,7 +94,7 @@ give gp = do
|
|||
, deadline = gpDeadline gp
|
||||
}
|
||||
tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp
|
||||
ledgerTx <- submitTxConstraints (inst p) tx
|
||||
ledgerTx <- submitTxConstraints (typedValidator p) tx
|
||||
void $ awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s"
|
||||
(gpAmount gp)
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import Data.Text (Text)
|
|||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract
|
||||
import PlutusTx (Data (..))
|
||||
import qualified PlutusTx
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Ledger hiding (singleton)
|
||||
|
|
@ -42,18 +43,17 @@ PlutusTx.unstableMakeIsData ''VestingDatum
|
|||
|
||||
{-# INLINABLE mkValidator #-}
|
||||
mkValidator :: VestingDatum -> () -> ScriptContext -> Bool
|
||||
mkValidator dat () ctx =
|
||||
traceIfFalse "beneficiary's signature missing" checkSig &&
|
||||
traceIfFalse "deadline not reached" checkDeadline
|
||||
mkValidator dat () ctx = traceIfFalse "beneficiary's signature missing" signedByBeneficiary &&
|
||||
traceIfFalse "deadline not reached" deadlineReached
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
checkSig :: Bool
|
||||
checkSig = beneficiary dat `elem` txInfoSignatories info
|
||||
signedByBeneficiary :: Bool
|
||||
signedByBeneficiary = txSignedBy info $ beneficiary dat
|
||||
|
||||
checkDeadline :: Bool
|
||||
checkDeadline = from (deadline dat) `contains` txInfoValidRange info
|
||||
deadlineReached :: Bool
|
||||
deadlineReached = contains (from $ deadline dat) $ txInfoValidRange info
|
||||
|
||||
data Vesting
|
||||
instance Scripts.ValidatorTypes Vesting where
|
||||
|
|
@ -70,6 +70,9 @@ typedValidator = Scripts.mkTypedValidator @Vesting
|
|||
validator :: Validator
|
||||
validator = Scripts.validatorScript typedValidator
|
||||
|
||||
valHash :: Ledger.ValidatorHash
|
||||
valHash = Scripts.validatorHash typedValidator
|
||||
|
||||
scrAddress :: Ledger.Address
|
||||
scrAddress = scriptAddress validator
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue