From 840d80a5853fd83b35be0b9ea968215a135e1aea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Wed, 14 Jul 2021 17:37:34 +0200 Subject: [PATCH] small modifications --- .../plutus-pioneer-program-week03.cabal | 4 +- code/week03/src/Week03/IsData.hs | 90 ------------------- code/week03/src/Week03/Parameterized.hs | 30 ++++--- code/week03/src/Week03/Vesting.hs | 17 ++-- 4 files changed, 28 insertions(+), 113 deletions(-) delete mode 100644 code/week03/src/Week03/IsData.hs diff --git a/code/week03/plutus-pioneer-program-week03.cabal b/code/week03/plutus-pioneer-program-week03.cabal index f087323..91502dd 100644 --- a/code/week03/plutus-pioneer-program-week03.cabal +++ b/code/week03/plutus-pioneer-program-week03.cabal @@ -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 diff --git a/code/week03/src/Week03/IsData.hs b/code/week03/src/Week03/IsData.hs deleted file mode 100644 index 05b9e3f..0000000 --- a/code/week03/src/Week03/IsData.hs +++ /dev/null @@ -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 [] diff --git a/code/week03/src/Week03/Parameterized.hs b/code/week03/src/Week03/Parameterized.hs index 43839c1..2c75e9a 100644 --- a/code/week03/src/Week03/Parameterized.hs +++ b/code/week03/src/Week03/Parameterized.hs @@ -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) diff --git a/code/week03/src/Week03/Vesting.hs b/code/week03/src/Week03/Vesting.hs index bc08e43..501a618 100644 --- a/code/week03/src/Week03/Vesting.hs +++ b/code/week03/src/Week03/Vesting.hs @@ -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