mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-13 10:22:34 +01:00
parameterized contract
This commit is contained in:
parent
57d14e4fb4
commit
9514e1258c
2 changed files with 120 additions and 0 deletions
|
@ -13,6 +13,7 @@ library
|
|||
exposed-modules: Week02.Burn
|
||||
, Week02.FortyTwo
|
||||
, Week02.Gift
|
||||
, Week02.Parameterized
|
||||
, Week02.Typed
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
|
|
119
code/week02/src/Week02/Parameterized.hs
Normal file
119
code/week02/src/Week02/Parameterized.hs
Normal file
|
@ -0,0 +1,119 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week02.Parameterized
|
||||
( give
|
||||
, grab
|
||||
, ParameterizedSchema
|
||||
, endpoints
|
||||
, schemas
|
||||
, registeredKnownCurrencies
|
||||
, printJson
|
||||
, printSchemas
|
||||
, ensureKnownCurrencies
|
||||
, stage
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
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 Schema (ToSchema)
|
||||
import Text.Printf (printf)
|
||||
|
||||
{-# INLINABLE mkParameterizedValidator #-}
|
||||
mkParameterizedValidator :: Integer -> () -> Integer -> ValidatorCtx -> Bool
|
||||
mkParameterizedValidator r () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == r)
|
||||
|
||||
data Parameterizing
|
||||
instance Scripts.ScriptType Parameterizing where
|
||||
type instance RedeemerType Parameterizing = Integer
|
||||
type instance DatumType Parameterizing = ()
|
||||
|
||||
parameterizedInstance :: Integer -> Scripts.ScriptInstance Parameterizing
|
||||
parameterizedInstance r = Scripts.validator @Parameterizing
|
||||
($$(PlutusTx.compile [|| mkParameterizedValidator ||])
|
||||
`PlutusTx.applyCode`
|
||||
PlutusTx.liftCode r)
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @() @Integer
|
||||
|
||||
parameterizedValidator :: Integer -> Validator
|
||||
parameterizedValidator = Scripts.validatorScript . parameterizedInstance
|
||||
|
||||
parameterizedHash :: Integer -> Ledger.ValidatorHash
|
||||
parameterizedHash = Scripts.validatorHash . parameterizedValidator
|
||||
|
||||
parameterizedAddress :: Integer -> Ledger.Address
|
||||
parameterizedAddress = ScriptAddress . parameterizedHash
|
||||
|
||||
type ParameterizedSchema =
|
||||
BlockchainActions
|
||||
.\/ Endpoint "give" GiveParams
|
||||
.\/ Endpoint "grab" GrabParams
|
||||
|
||||
data GiveParams = GiveParams
|
||||
{ giveAmount :: Integer
|
||||
, giveParameter :: Integer
|
||||
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||
|
||||
data GrabParams = GrabParams
|
||||
{ grabParameter :: Integer
|
||||
, grabRedeemer :: Integer
|
||||
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||
|
||||
give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e ()
|
||||
give p = do
|
||||
let amount = giveAmount p
|
||||
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
||||
ledgerTx <- submitTxConstraints (parameterizedInstance $ giveParameter p) tx
|
||||
void $ awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ printf "made a gift of %d lovelace" amount
|
||||
|
||||
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => GrabParams -> Contract w s e ()
|
||||
grab p = do
|
||||
let par = grabParameter p
|
||||
utxos <- utxoAt $ ScriptAddress $ parameterizedHash par
|
||||
let orefs = fst <$> Map.toList utxos
|
||||
lookups = Constraints.unspentOutputs utxos <>
|
||||
Constraints.otherScript (parameterizedValidator par)
|
||||
tx :: TxConstraints Void Void
|
||||
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I $ grabRedeemer p | oref <- orefs]
|
||||
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||
void $ awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "collected gifts"
|
||||
|
||||
endpoints :: Contract () ParameterizedSchema Text ()
|
||||
endpoints = (give' `select` grab') >> endpoints
|
||||
where
|
||||
give' = endpoint @"give" >>= give
|
||||
grab' = endpoint @"grab" >>= grab
|
||||
|
||||
mkSchemaDefinitions ''ParameterizedSchema
|
||||
|
||||
mkKnownCurrencies []
|
Loading…
Reference in a new issue