diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index a6ca46e..fcf3c20 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -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 diff --git a/code/week02/src/Week02/Parameterized.hs b/code/week02/src/Week02/Parameterized.hs new file mode 100644 index 0000000..e1e065f --- /dev/null +++ b/code/week02/src/Week02/Parameterized.hs @@ -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 []