From 509ad92703f394d474e386517786cfd05c653734 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Lars=20Br=C3=BCnjes?= Date: Sat, 10 Apr 2021 00:08:26 +0200 Subject: [PATCH] FortyTwo contract --- .../plutus-pioneer-program-week02.cabal | 1 + code/week02/src/Week02/Burn.hs | 9 +- code/week02/src/Week02/FortyTwo.hs | 89 +++++++++++++++++++ code/week02/src/Week02/Gift.hs | 3 +- 4 files changed, 97 insertions(+), 5 deletions(-) create mode 100644 code/week02/src/Week02/FortyTwo.hs diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index 4df0f37..ca20981 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -11,6 +11,7 @@ License-files: LICENSE library hs-source-dirs: src exposed-modules: Week02.Burn + , Week02.FortyTwo , Week02.Gift 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 340dbba..359dc36 100644 --- a/code/week02/src/Week02/Burn.hs +++ b/code/week02/src/Week02/Burn.hs @@ -11,6 +11,7 @@ module Week02.Burn ( burn , grab + , BurnSchema , endpoints , schemas , registeredKnownCurrencies @@ -51,14 +52,14 @@ giftHash = Scripts.validatorHash giftValidator giftAddress :: Ledger.Address giftAddress = ScriptAddress giftHash -type GiftSchema = +type BurnSchema = BlockchainActions .\/ Endpoint "burn" Integer .\/ Endpoint "grab" () burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () burn amount = do - let tx = mustPayToOtherScript giftHash (Datum $ I 42) $ Ada.lovelaceValueOf amount + let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "burnt %d lovelace" amount @@ -75,12 +76,12 @@ grab = do void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ "collected gifts" -endpoints :: Contract () GiftSchema Text () +endpoints :: Contract () BurnSchema Text () endpoints = (give' `select` grab') >> endpoints where give' = endpoint @"burn" >>= burn grab' = endpoint @"grab" >> grab -mkSchemaDefinitions ''GiftSchema +mkSchemaDefinitions ''BurnSchema mkKnownCurrencies [] diff --git a/code/week02/src/Week02/FortyTwo.hs b/code/week02/src/Week02/FortyTwo.hs new file mode 100644 index 0000000..469e9d6 --- /dev/null +++ b/code/week02/src/Week02/FortyTwo.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.FortyTwo + ( give + , grab + , FortyTwoSchema + , 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 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 mkGiftValidator #-} +mkGiftValidator :: Data -> Data -> Data -> () +mkGiftValidator _ (I n) _ + | n == 42 = () +mkGiftValidator _ _ _ = traceError "UNEXPECTED REDEEMER!" + +giftValidator :: Validator +giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) + +giftHash :: Ledger.ValidatorHash +giftHash = Scripts.validatorHash giftValidator + +giftAddress :: Ledger.Address +giftAddress = ScriptAddress giftHash + +type FortyTwoSchema = + BlockchainActions + .\/ Endpoint "give" Integer + .\/ Endpoint "grab" Integer + +give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () +give amount = do + let tx = mustPayToOtherScript giftHash (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 + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript giftValidator + 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 = (give' `select` grab') >> endpoints + where + give' = endpoint @"give" >>= give + grab' = endpoint @"grab" >>= grab + +mkSchemaDefinitions ''FortyTwoSchema + +mkKnownCurrencies [] diff --git a/code/week02/src/Week02/Gift.hs b/code/week02/src/Week02/Gift.hs index fc79dc4..9133f1b 100644 --- a/code/week02/src/Week02/Gift.hs +++ b/code/week02/src/Week02/Gift.hs @@ -10,6 +10,7 @@ module Week02.Gift ( give , grab + , GiftSchema , endpoints , schemas , registeredKnownCurrencies @@ -57,7 +58,7 @@ type GiftSchema = give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e () give amount = do - let tx = mustPayToOtherScript giftHash (Datum $ I 42) $ Ada.lovelaceValueOf amount + let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount ledgerTx <- submitTx tx void $ awaitTxConfirmed $ txId ledgerTx logInfo @String $ printf "made a gift of %d lovelace" amount