diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index acd6f4f..4df0f37 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -10,7 +10,8 @@ License-files: LICENSE library hs-source-dirs: src - exposed-modules: Week02.Gift + exposed-modules: Week02.Burn + , Week02.Gift 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 new file mode 100644 index 0000000..340dbba --- /dev/null +++ b/code/week02/src/Week02/Burn.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Week02.Burn + ( burn + , grab + , 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 _ _ _ = traceError "NO WAY!" + +giftValidator :: Validator +giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||]) + +giftHash :: Ledger.ValidatorHash +giftHash = Scripts.validatorHash giftValidator + +giftAddress :: Ledger.Address +giftAddress = ScriptAddress giftHash + +type GiftSchema = + 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 + 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 + let orefs = fst <$> Map.toList utxos + lookups = Constraints.unspentOutputs utxos <> + Constraints.otherScript giftValidator + 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 () GiftSchema Text () +endpoints = (give' `select` grab') >> endpoints + where + give' = endpoint @"burn" >>= burn + grab' = endpoint @"grab" >> grab + +mkSchemaDefinitions ''GiftSchema + +mkKnownCurrencies []