mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-22 06:42:00 +01:00
Typed contract
This commit is contained in:
parent
509ad92703
commit
57d14e4fb4
4 changed files with 127 additions and 26 deletions
|
@ -13,6 +13,7 @@ library
|
||||||
exposed-modules: Week02.Burn
|
exposed-modules: Week02.Burn
|
||||||
, Week02.FortyTwo
|
, Week02.FortyTwo
|
||||||
, Week02.Gift
|
, Week02.Gift
|
||||||
|
, Week02.Typed
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
, containers
|
, containers
|
||||||
|
|
|
@ -39,18 +39,18 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkGiftValidator #-}
|
{-# INLINABLE mkBurnValidator #-}
|
||||||
mkGiftValidator :: Data -> Data -> Data -> ()
|
mkBurnValidator :: Data -> Data -> Data -> ()
|
||||||
mkGiftValidator _ _ _ = traceError "NO WAY!"
|
mkBurnValidator _ _ _ = traceError "NO WAY!"
|
||||||
|
|
||||||
giftValidator :: Validator
|
burnValidator :: Validator
|
||||||
giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
|
burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||])
|
||||||
|
|
||||||
giftHash :: Ledger.ValidatorHash
|
burnHash :: Ledger.ValidatorHash
|
||||||
giftHash = Scripts.validatorHash giftValidator
|
burnHash = Scripts.validatorHash burnValidator
|
||||||
|
|
||||||
giftAddress :: Ledger.Address
|
burnAddress :: Ledger.Address
|
||||||
giftAddress = ScriptAddress giftHash
|
burnAddress = ScriptAddress burnHash
|
||||||
|
|
||||||
type BurnSchema =
|
type BurnSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
|
@ -59,17 +59,17 @@ type BurnSchema =
|
||||||
|
|
||||||
burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
||||||
burn amount = do
|
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
|
ledgerTx <- submitTx tx
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ printf "burnt %d lovelace" amount
|
logInfo @String $ printf "burnt %d lovelace" amount
|
||||||
|
|
||||||
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
|
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
|
||||||
grab = do
|
grab = do
|
||||||
utxos <- utxoAt $ ScriptAddress giftHash
|
utxos <- utxoAt $ ScriptAddress burnHash
|
||||||
let orefs = fst <$> Map.toList utxos
|
let orefs = fst <$> Map.toList utxos
|
||||||
lookups = Constraints.unspentOutputs utxos <>
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
Constraints.otherScript giftValidator
|
Constraints.otherScript burnValidator
|
||||||
tx :: TxConstraints Void Void
|
tx :: TxConstraints Void Void
|
||||||
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs]
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs]
|
||||||
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||||
|
|
|
@ -39,20 +39,20 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkGiftValidator #-}
|
{-# INLINABLE mkFortyTwoValidator #-}
|
||||||
mkGiftValidator :: Data -> Data -> Data -> ()
|
mkFortyTwoValidator :: Data -> Data -> Data -> ()
|
||||||
mkGiftValidator _ (I n) _
|
mkFortyTwoValidator _ (I n) _
|
||||||
| n == 42 = ()
|
| n == 42 = ()
|
||||||
mkGiftValidator _ _ _ = traceError "UNEXPECTED REDEEMER!"
|
mkFortyTwoValidator _ _ _ = traceError "UNEXPECTED REDEEMER!"
|
||||||
|
|
||||||
giftValidator :: Validator
|
fortyTwoValidator :: Validator
|
||||||
giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
|
fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||])
|
||||||
|
|
||||||
giftHash :: Ledger.ValidatorHash
|
fortyTwoHash :: Ledger.ValidatorHash
|
||||||
giftHash = Scripts.validatorHash giftValidator
|
fortyTwoHash = Scripts.validatorHash fortyTwoValidator
|
||||||
|
|
||||||
giftAddress :: Ledger.Address
|
fortyTwoAddress :: Ledger.Address
|
||||||
giftAddress = ScriptAddress giftHash
|
fortyTwoAddress = ScriptAddress fortyTwoHash
|
||||||
|
|
||||||
type FortyTwoSchema =
|
type FortyTwoSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
|
@ -61,17 +61,17 @@ type FortyTwoSchema =
|
||||||
|
|
||||||
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
||||||
give amount = do
|
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
|
ledgerTx <- submitTx tx
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ printf "made a gift of %d lovelace" amount
|
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 :: forall w s e. (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
||||||
grab r = do
|
grab r = do
|
||||||
utxos <- utxoAt $ ScriptAddress giftHash
|
utxos <- utxoAt $ ScriptAddress fortyTwoHash
|
||||||
let orefs = fst <$> Map.toList utxos
|
let orefs = fst <$> Map.toList utxos
|
||||||
lookups = Constraints.unspentOutputs utxos <>
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
Constraints.otherScript giftValidator
|
Constraints.otherScript fortyTwoValidator
|
||||||
tx :: TxConstraints Void Void
|
tx :: TxConstraints Void Void
|
||||||
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs]
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I r | oref <- orefs]
|
||||||
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||||
|
|
100
code/week02/src/Week02/Typed.hs
Normal file
100
code/week02/src/Week02/Typed.hs
Normal file
|
@ -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 []
|
Loading…
Reference in a new issue