parameterized contract

This commit is contained in:
Lars Brünjes 2021-04-10 01:03:13 +02:00
parent 57d14e4fb4
commit 9514e1258c
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
2 changed files with 120 additions and 0 deletions

View file

@ -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

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