burn script

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

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 []