From 57d14e4fb4d665447c1716bd2e1ccc9fa91e8b6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Sat, 10 Apr 2021 00:33:33 +0200 Subject: [PATCH] Typed contract --- .../plutus-pioneer-program-week02.cabal | 1 + code/week02/src/Week02/Burn.hs | 24 ++--- code/week02/src/Week02/FortyTwo.hs | 28 ++--- code/week02/src/Week02/Typed.hs | 100 ++++++++++++++++++ 4 files changed, 127 insertions(+), 26 deletions(-) create mode 100644 code/week02/src/Week02/Typed.hs diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index ca20981..a6ca46e 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -13,6 +13,7 @@ library exposed-modules: Week02.Burn , Week02.FortyTwo , Week02.Gift + , Week02.Typed build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week02/src/Week02/Burn.hs b/code/week02/src/Week02/Burn.hs index 359dc36..0735d23 100644 --- a/code/week02/src/Week02/Burn.hs +++ b/code/week02/src/Week02/Burn.hs @@ -39,18 +39,18 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkGiftValidator #-} -mkGiftValidator :: Data -> Data -> Data -> () -mkGiftValidator _ _ _ = traceError "NO WAY!" +{-# INLINABLE mkBurnValidator #-} +mkBurnValidator :: Data -> Data -> Data -> () +mkBurnValidator _ _ _ = traceError "NO WAY!" -giftValidator :: Validator -giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) +burnValidator :: Validator +burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||]) -giftHash :: Ledger.ValidatorHash -giftHash = Scripts.validatorHash giftValidator +burnHash :: Ledger.ValidatorHash +burnHash = Scripts.validatorHash burnValidator -giftAddress :: Ledger.Address -giftAddress = ScriptAddress giftHash +burnAddress :: Ledger.Address +burnAddress = ScriptAddress burnHash type BurnSchema = BlockchainActions @@ -59,17 +59,17 @@ type BurnSchema = burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () burn amount = do - let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount + let tx = mustPayToOtherScript burnHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "burnt %d lovelace" amount grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e () grab = do - utxos <- utxoAt $ ScriptAddress giftHash + utxos <- utxoAt $ ScriptAddress burnHash let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript giftValidator + Constraints.otherScript burnValidator 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/FortyTwo.hs b/code/week02/src/Week02/FortyTwo.hs index 469e9d6..d241cf1 100644 --- a/code/week02/src/Week02/FortyTwo.hs +++ b/code/week02/src/Week02/FortyTwo.hs @@ -39,20 +39,20 @@ import Playground.Types (KnownCurrency (..)) import Prelude (Semigroup (..)) import Text.Printf (printf) -{-# INLINABLE mkGiftValidator #-} -mkGiftValidator :: Data -> Data -> Data -> () -mkGiftValidator _ (I n) _ - | n == 42 = () -mkGiftValidator _ _ _ = traceError "UNEXPECTED REDEEMER!" +{-# INLINABLE mkFortyTwoValidator #-} +mkFortyTwoValidator :: Data -> Data -> Data -> () +mkFortyTwoValidator _ (I n) _ + | n == 42 = () +mkFortyTwoValidator _ _ _ = traceError "UNEXPECTED REDEEMER!" -giftValidator :: Validator -giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) +fortyTwoValidator :: Validator +fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||]) -giftHash :: Ledger.ValidatorHash -giftHash = Scripts.validatorHash giftValidator +fortyTwoHash :: Ledger.ValidatorHash +fortyTwoHash = Scripts.validatorHash fortyTwoValidator -giftAddress :: Ledger.Address -giftAddress = ScriptAddress giftHash +fortyTwoAddress :: Ledger.Address +fortyTwoAddress = ScriptAddress fortyTwoHash type FortyTwoSchema = BlockchainActions @@ -61,17 +61,17 @@ type FortyTwoSchema = 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 fortyTwoHash (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 giftHash + utxos <- utxoAt $ ScriptAddress fortyTwoHash let orefs = fst <$> Map.toList utxos lookups = Constraints.unspentOutputs utxos <> - Constraints.otherScript giftValidator + Constraints.otherScript fortyTwoValidator tx :: TxConstraints Void Void tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs] ledgerTx <- submitTxConstraintsWith @Void lookups tx diff --git a/code/week02/src/Week02/Typed.hs b/code/week02/src/Week02/Typed.hs new file mode 100644 index 0000000..92308ab --- /dev/null +++ b/code/week02/src/Week02/Typed.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Typed + ( give + , grab + , TypedSchema + , endpoints + , schemas + , registeredKnownCurrencies + , printJson + , printSchemas + , ensureKnownCurrencies + , stage + ) 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 mkTypedValidator #-} +mkTypedValidator :: () -> Integer -> ValidatorCtx -> Bool +mkTypedValidator () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == 42) + +data Typing +instance Scripts.ScriptType Typing where + type instance RedeemerType Typing = Integer + type instance DatumType Typing = () + +typedInstance :: Scripts.ScriptInstance Typing +typedInstance = Scripts.validator @Typing + $$(PlutusTx.compile [|| mkTypedValidator ||]) + $$(PlutusTx.compile [|| wrap ||]) + where + wrap = Scripts.wrapValidator @() @Integer + +typedValidator :: Validator +typedValidator = Scripts.validatorScript typedInstance + +typedHash :: Ledger.ValidatorHash +typedHash = Scripts.validatorHash typedValidator + +typedAddress :: Ledger.Address +typedAddress = ScriptAddress typedHash + +type TypedSchema = + 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 typedInstance 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 + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript typedValidator + 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 = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >>= grab + +mkSchemaDefinitions ''TypedSchema + +mkKnownCurrencies []