From 0e9277b6f8f2e0c4406ce7d7a377321589c2a170 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Mon, 12 Apr 2021 22:59:51 +0200 Subject: [PATCH] finished code for week 2 --- README.md | 1 + .../plutus-pioneer-program-week02.cabal | 4 +- code/week02/src/Week02/Burn.hs | 53 ++++---- code/week02/src/Week02/FortyTwo.hs | 47 +++---- code/week02/src/Week02/Gift.hs | 37 ++---- code/week02/src/Week02/Homework1.hs | 85 +++++++++++++ code/week02/src/Week02/Homework2.hs | 96 ++++++++++++++ code/week02/src/Week02/IsData.hs | 94 ++++++++++++++ code/week02/src/Week02/Parameterized.hs | 119 ------------------ code/week02/src/Week02/Typed.hs | 59 ++++----- 10 files changed, 356 insertions(+), 239 deletions(-) create mode 100644 code/week02/src/Week02/Homework1.hs create mode 100644 code/week02/src/Week02/Homework2.hs create mode 100644 code/week02/src/Week02/IsData.hs delete mode 100644 code/week02/src/Week02/Parameterized.hs diff --git a/README.md b/README.md index 13af6dc..2ea8b58 100644 --- a/README.md +++ b/README.md @@ -31,6 +31,7 @@ ## Some Plutus Modules - [`PlutusTx.Data`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/Data.hs), contains the definition of the `Data` type. +- [`PlutusTx.IsData.Class`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/IsData/Class.hs), defines the `IsData` class. ## Additional Resources diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index fcf3c20..d88f361 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -12,8 +12,10 @@ library hs-source-dirs: src exposed-modules: Week02.Burn , Week02.FortyTwo + , Week02.Homework1 + , Week02.Homework2 , Week02.Gift - , Week02.Parameterized + , Week02.IsData , Week02.Typed build-depends: aeson , base ^>=4.14.1.0 diff --git a/code/week02/src/Week02/Burn.hs b/code/week02/src/Week02/Burn.hs index 0735d23..2b38b5f 100644 --- a/code/week02/src/Week02/Burn.hs +++ b/code/week02/src/Week02/Burn.hs @@ -8,18 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week02.Burn - ( burn - , grab - , BurnSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) where +module Week02.Burn where import Control.Monad hiding (fmap) import Data.Map as Map @@ -39,49 +28,49 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkBurnValidator #-} -mkBurnValidator :: Data -> Data -> Data -> () -mkBurnValidator _ _ _ = traceError "NO WAY!" +{-# INLINABLE mkValidator #-} +mkValidator :: Data -> Data -> Data -> () +mkValidator _ _ _ = traceError "NO WAY!" -burnValidator :: Validator -burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||]) +validator :: Validator +validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||]) -burnHash :: Ledger.ValidatorHash -burnHash = Scripts.validatorHash burnValidator +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator -burnAddress :: Ledger.Address -burnAddress = ScriptAddress burnHash +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash -type BurnSchema = +type GiftSchema = BlockchainActions - .\/ Endpoint "burn" Integer + .\/ Endpoint "give" Integer .\/ Endpoint "grab" () -burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () -burn amount = do - let tx = mustPayToOtherScript burnHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "burnt %d lovelace" amount + logInfo @String $ printf "made a gift of %d lovelace" amount grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () grab = do - utxos <- utxoAt $ ScriptAddress burnHash + utxos <- utxoAt scrAddress let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript burnValidator + Constraints.otherScript validator tx :: TxConstraints Void Void tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs] ledgerTx <- submitTxConstraintsWith @Void lookups tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ "collected gifts" -endpoints :: Contract () BurnSchema Text () +endpoints :: Contract () GiftSchema Text () endpoints = (give' `select` grab') >> endpoints where - give' = endpoint @"burn" >>= burn + give' = endpoint @"give" >>= give grab' = endpoint @"grab" >> grab -mkSchemaDefinitions ''BurnSchema +mkSchemaDefinitions ''GiftSchema mkKnownCurrencies [] diff --git a/code/week02/src/Week02/FortyTwo.hs b/code/week02/src/Week02/FortyTwo.hs index d241cf1..691bd78 100644 --- a/code/week02/src/Week02/FortyTwo.hs +++ b/code/week02/src/Week02/FortyTwo.hs @@ -8,18 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week02.FortyTwo - ( give - , grab - , FortyTwoSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) where +module Week02.FortyTwo where import Control.Monad hiding (fmap) import Data.Map as Map @@ -39,51 +28,51 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkFortyTwoValidator #-} -mkFortyTwoValidator :: Data -> Data -> Data -> () -mkFortyTwoValidator _ (I n) _ - | n == 42 = () -mkFortyTwoValidator _ _ _ = traceError "UNEXPECTED REDEEMER!" +{-# INLINABLE mkValidator #-} +mkValidator :: Data -> Data -> Data -> () +mkValidator _ r _ + | r == I 42 = () + | otherwise = traceError "wrong redeemer" -fortyTwoValidator :: Validator -fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||]) +validator :: Validator +validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||]) -fortyTwoHash :: Ledger.ValidatorHash -fortyTwoHash = Scripts.validatorHash fortyTwoValidator +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator -fortyTwoAddress :: Ledger.Address -fortyTwoAddress = ScriptAddress fortyTwoHash +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash -type FortyTwoSchema = +type GiftSchema = BlockchainActions .\/ Endpoint "give" Integer .\/ Endpoint "grab" Integer give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () give amount = do - let tx = mustPayToOtherScript fortyTwoHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount + let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "made a gift of %d lovelace" amount grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () grab r = do - utxos <- utxoAt $ ScriptAddress fortyTwoHash + utxos <- utxoAt scrAddress let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript fortyTwoValidator + Constraints.otherScript validator tx :: TxConstraints Void Void tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs] ledgerTx <- submitTxConstraintsWith @Void lookups tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ "collected gifts" -endpoints :: Contract () FortyTwoSchema Text () +endpoints :: Contract () GiftSchema Text () endpoints = (give' `select` grab') >> endpoints where give' = endpoint @"give" >>= give grab' = endpoint @"grab" >>= grab -mkSchemaDefinitions ''FortyTwoSchema +mkSchemaDefinitions ''GiftSchema mkKnownCurrencies [] diff --git a/code/week02/src/Week02/Gift.hs b/code/week02/src/Week02/Gift.hs index 9133f1b..73221e0 100644 --- a/code/week02/src/Week02/Gift.hs +++ b/code/week02/src/Week02/Gift.hs @@ -7,18 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week02.Gift - ( give - , grab - , GiftSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) where +module Week02.Gift where import Control.Monad hiding (fmap) import Data.Map as Map @@ -38,18 +27,18 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkGiftValidator #-} -mkGiftValidator :: Data -> Data -> Data -> () -mkGiftValidator _ _ _ = () +{-# INLINABLE mkValidator #-} +mkValidator :: Data -> Data -> Data -> () +mkValidator _ _ _ = () -giftValidator :: Validator -giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) +validator :: Validator +validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||]) -giftHash :: Ledger.ValidatorHash -giftHash = Scripts.validatorHash giftValidator +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator -giftAddress :: Ledger.Address -giftAddress = ScriptAddress giftHash +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash type GiftSchema = BlockchainActions @@ -58,17 +47,17 @@ type GiftSchema = give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () give amount = do - let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount + let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "made a gift of %d lovelace" amount grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () grab = do - utxos <- utxoAt $ ScriptAddress giftHash + utxos <- utxoAt scrAddress let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript giftValidator + Constraints.otherScript validator tx :: TxConstraints Void Void tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs] ledgerTx <- submitTxConstraintsWith @Void lookups tx diff --git a/code/week02/src/Week02/Homework1.hs b/code/week02/src/Week02/Homework1.hs new file mode 100644 index 0000000..72bfaf5 --- /dev/null +++ b/code/week02/src/Week02/Homework1.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Homework1 where + +import Control.Monad hiding (fmap) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +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.Scripts as Scripts +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 (Semigroup (..)) +import Text.Printf (printf) + +{-# INLINABLE mkValidator #-} +-- This should validate if and only if the two Booleans in the redeemer are equal! +mkValidator :: () -> (Bool, Bool) -> ValidatorCtx -> Bool +mkValidator _ _ _ = True -- FIX ME! + +data Typed +instance Scripts.ScriptType Typed where +-- Implement the instance! + +inst :: Scripts.ScriptInstance Typed +inst = undefined -- FIX ME! + +validator :: Validator +validator = undefined -- FIX ME! + +valHash :: Ledger.ValidatorHash +valHash = undefined -- FIX ME! + +scrAddress :: Ledger.Address +scrAddress = undefined -- FIX ME! + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" (Bool, Bool) + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => (Bool, Bool) -> Contract w s e () +grab bs = 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 bs | 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/week02/src/Week02/Homework2.hs b/code/week02/src/Week02/Homework2.hs new file mode 100644 index 0000000..7a3acb9 --- /dev/null +++ b/code/week02/src/Week02/Homework2.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Homework2 where + +import Control.Monad hiding (fmap) +import Data.Aeson (FromJSON, ToJSON) +import Data.Map as Map +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.Scripts as Scripts +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) + +data MyRedeemer = MyRedeemer + { flag1 :: Bool + , flag2 :: Bool + } deriving (Generic, FromJSON, ToJSON, ToSchema) + +PlutusTx.unstableMakeIsData ''MyRedeemer + +{-# INLINABLE mkValidator #-} +-- This should validate if and only if the two Booleans in the redeemer are equal! +mkValidator :: () -> MyRedeemer -> ValidatorCtx -> Bool +mkValidator _ _ _ = True -- FIX ME! + +data Typed +instance Scripts.ScriptType Typed where + -- Implement me! + +inst :: Scripts.ScriptInstance Typed +inst = undefined -- FIX ME! + +validator :: Validator +validator = undefined -- FIX ME! + +valHash :: Ledger.ValidatorHash +valHash = undefined -- FIX ME! + +scrAddress :: Ledger.Address +scrAddress = undefined -- FIX ME! + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" MyRedeemer + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => MyRedeemer -> 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 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/week02/src/Week02/IsData.hs b/code/week02/src/Week02/IsData.hs new file mode 100644 index 0000000..a0152ee --- /dev/null +++ b/code/week02/src/Week02/IsData.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.IsData where + +import Control.Monad hiding (fmap) +import Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +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.Scripts as Scripts +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 (Semigroup (..)) +import Text.Printf (printf) + +newtype MySillyRedeemer = MySillyRedeemer Integer + deriving Show + +PlutusTx.unstableMakeIsData ''MySillyRedeemer + +{-# INLINABLE mkValidator #-} +mkValidator :: () -> MySillyRedeemer -> ValidatorCtx -> Bool +mkValidator () (MySillyRedeemer r) _ = traceIfFalse "wrong redeemer" $ r == 42 + +data Typed +instance Scripts.ScriptType Typed where + type instance DatumType Typed = () + type instance RedeemerType Typed = MySillyRedeemer + +inst :: Scripts.ScriptInstance Typed +inst = Scripts.validator @Typed + $$(PlutusTx.compile [|| mkValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @() @MySillyRedeemer + +validator :: Validator +validator = Scripts.validatorScript inst + +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator + +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash + +type GiftSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" Integer + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount + ledgerTx <- submitTxConstraints inst tx + void $ awaitTxConfirmed $ txId ledgerTx + logInfo @String $ printf "made a gift of %d lovelace" amount + +grab :: forall w s e. (HasBlockchainActions s, 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/week02/src/Week02/Parameterized.hs b/code/week02/src/Week02/Parameterized.hs deleted file mode 100644 index e1e065f..0000000 --- a/code/week02/src/Week02/Parameterized.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Week02.Parameterized - ( give - , grab - , ParameterizedSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) 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 PlutusTx (Data (..)) -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup(..), unless) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import qualified Ledger.Scripts as Scripts -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 (Semigroup (..)) -import Schema (ToSchema) -import Text.Printf (printf) - -{-# INLINABLE mkParameterizedValidator #-} -mkParameterizedValidator :: Integer -> () -> Integer -> ValidatorCtx -> Bool -mkParameterizedValidator r () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == r) - -data Parameterizing -instance Scripts.ScriptType Parameterizing where - type instance RedeemerType Parameterizing = Integer - type instance DatumType Parameterizing = () - -parameterizedInstance :: Integer -> Scripts.ScriptInstance Parameterizing -parameterizedInstance r = Scripts.validator @Parameterizing - ($$(PlutusTx.compile [|| mkParameterizedValidator ||]) - `PlutusTx.applyCode` - PlutusTx.liftCode r) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @() @Integer - -parameterizedValidator :: Integer -> Validator -parameterizedValidator = Scripts.validatorScript . parameterizedInstance - -parameterizedHash :: Integer -> Ledger.ValidatorHash -parameterizedHash = Scripts.validatorHash . parameterizedValidator - -parameterizedAddress :: Integer -> Ledger.Address -parameterizedAddress = ScriptAddress . parameterizedHash - -type ParameterizedSchema = - BlockchainActions - .\/ Endpoint "give" GiveParams - .\/ Endpoint "grab" GrabParams - -data GiveParams = GiveParams - { giveAmount :: Integer - , giveParameter :: Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -data GrabParams = GrabParams - { grabParameter :: Integer - , grabRedeemer :: Integer - } deriving (Generic, ToJSON, FromJSON, ToSchema) - -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 - void $ awaitTxConfirmed $ txId ledgerTx - logInfo @String $ printf "made a gift of %d lovelace" amount - -grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => GrabParams -> Contract w s e () -grab p = do - let par = grabParameter p - utxos <- utxoAt $ ScriptAddress $ parameterizedHash 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" - -endpoints :: Contract () ParameterizedSchema Text () -endpoints = (give' `select` grab') >> endpoints - where - give' = endpoint @"give" >>= give - grab' = endpoint @"grab" >>= grab - -mkSchemaDefinitions ''ParameterizedSchema - -mkKnownCurrencies [] diff --git a/code/week02/src/Week02/Typed.hs b/code/week02/src/Week02/Typed.hs index 92308ab..8dbf0a5 100644 --- a/code/week02/src/Week02/Typed.hs +++ b/code/week02/src/Week02/Typed.hs @@ -8,18 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Week02.Typed - ( give - , grab - , TypedSchema - , endpoints - , schemas - , registeredKnownCurrencies - , printJson - , printSchemas - , ensureKnownCurrencies - , stage - ) where +module Week02.Typed where import Control.Monad hiding (fmap) import Data.Map as Map @@ -40,32 +29,34 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkTypedValidator #-} -mkTypedValidator :: () -> Integer -> ValidatorCtx -> Bool -mkTypedValidator () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == 42) +{-# INLINABLE mkValidator #-} +mkValidator :: () -> Integer -> ValidatorCtx -> Bool +mkValidator () r _ + | r == 42 = True + | otherwise = False -data Typing -instance Scripts.ScriptType Typing where - type instance RedeemerType Typing = Integer - type instance DatumType Typing = () +data Typed +instance Scripts.ScriptType Typed where + type instance DatumType Typed = () + type instance RedeemerType Typed = Integer -typedInstance :: Scripts.ScriptInstance Typing -typedInstance = Scripts.validator @Typing - $$(PlutusTx.compile [|| mkTypedValidator ||]) +inst :: Scripts.ScriptInstance Typed +inst = Scripts.validator @Typed + $$(PlutusTx.compile [|| mkValidator ||]) $$(PlutusTx.compile [|| wrap ||]) where wrap = Scripts.wrapValidator @() @Integer -typedValidator :: Validator -typedValidator = Scripts.validatorScript typedInstance +validator :: Validator +validator = Scripts.validatorScript inst -typedHash :: Ledger.ValidatorHash -typedHash = Scripts.validatorHash typedValidator +valHash :: Ledger.ValidatorHash +valHash = Scripts.validatorHash validator -typedAddress :: Ledger.Address -typedAddress = ScriptAddress typedHash +scrAddress :: Ledger.Address +scrAddress = ScriptAddress valHash -type TypedSchema = +type GiftSchema = BlockchainActions .\/ Endpoint "give" Integer .\/ Endpoint "grab" Integer @@ -73,28 +64,28 @@ type TypedSchema = give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () give amount = do let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount - ledgerTx <- submitTxConstraints typedInstance tx + ledgerTx <- submitTxConstraints inst tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "made a gift of %d lovelace" amount grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () grab r = do - utxos <- utxoAt $ ScriptAddress typedHash + utxos <- utxoAt scrAddress let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript typedValidator + Constraints.otherScript validator tx :: TxConstraints Void Void tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs] ledgerTx <- submitTxConstraintsWith @Void lookups tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ "collected gifts" -endpoints :: Contract () TypedSchema Text () +endpoints :: Contract () GiftSchema Text () endpoints = (give' `select` grab') >> endpoints where give' = endpoint @"give" >>= give grab' = endpoint @"grab" >>= grab -mkSchemaDefinitions ''TypedSchema +mkSchemaDefinitions ''GiftSchema mkKnownCurrencies []