finished code for week 2

This commit is contained in:
Lars Brünjes 2021-04-12 22:59:51 +02:00
parent a739b2fe6e
commit 0e9277b6f8
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
10 changed files with 356 additions and 239 deletions

View file

@ -31,6 +31,7 @@
## Some Plutus Modules
- [`PlutusTx.Data`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/Data.hs), contains the definition of the `Data` type.
- [`PlutusTx.IsData.Class`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/IsData/Class.hs), defines the `IsData` class.
## Additional Resources

View file

@ -12,8 +12,10 @@ library
hs-source-dirs: src
exposed-modules: Week02.Burn
, Week02.FortyTwo
, Week02.Homework1
, Week02.Homework2
, Week02.Gift
, Week02.Parameterized
, Week02.IsData
, Week02.Typed
build-depends: aeson
, base ^>=4.14.1.0

View file

@ -8,18 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Burn
( burn
, grab
, BurnSchema
, endpoints
, schemas
, registeredKnownCurrencies
, printJson
, printSchemas
, ensureKnownCurrencies
, stage
) where
module Week02.Burn where
import Control.Monad hiding (fmap)
import Data.Map as Map
@ -39,49 +28,49 @@ import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
{-# INLINABLE mkBurnValidator #-}
mkBurnValidator :: Data -> Data -> Data -> ()
mkBurnValidator _ _ _ = traceError "NO WAY!"
{-# INLINABLE mkValidator #-}
mkValidator :: Data -> Data -> Data -> ()
mkValidator _ _ _ = traceError "NO WAY!"
burnValidator :: Validator
burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||])
validator :: Validator
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
burnHash :: Ledger.ValidatorHash
burnHash = Scripts.validatorHash burnValidator
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
burnAddress :: Ledger.Address
burnAddress = ScriptAddress burnHash
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type BurnSchema =
type GiftSchema =
BlockchainActions
.\/ Endpoint "burn" Integer
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" ()
burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
burn amount = do
let tx = mustPayToOtherScript burnHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
ledgerTx <- submitTx tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "burnt %d lovelace" amount
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
grab = do
utxos <- utxoAt $ ScriptAddress burnHash
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript burnValidator
Constraints.otherScript validator
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 () BurnSchema Text ()
endpoints :: Contract () GiftSchema Text ()
endpoints = (give' `select` grab') >> endpoints
where
give' = endpoint @"burn" >>= burn
give' = endpoint @"give" >>= give
grab' = endpoint @"grab" >> grab
mkSchemaDefinitions ''BurnSchema
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

View file

@ -8,18 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.FortyTwo
( give
, grab
, FortyTwoSchema
, endpoints
, schemas
, registeredKnownCurrencies
, printJson
, printSchemas
, ensureKnownCurrencies
, stage
) where
module Week02.FortyTwo where
import Control.Monad hiding (fmap)
import Data.Map as Map
@ -39,51 +28,51 @@ import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
{-# INLINABLE mkFortyTwoValidator #-}
mkFortyTwoValidator :: Data -> Data -> Data -> ()
mkFortyTwoValidator _ (I n) _
| n == 42 = ()
mkFortyTwoValidator _ _ _ = traceError "UNEXPECTED REDEEMER!"
{-# INLINABLE mkValidator #-}
mkValidator :: Data -> Data -> Data -> ()
mkValidator _ r _
| r == I 42 = ()
| otherwise = traceError "wrong redeemer"
fortyTwoValidator :: Validator
fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||])
validator :: Validator
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
fortyTwoHash :: Ledger.ValidatorHash
fortyTwoHash = Scripts.validatorHash fortyTwoValidator
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
fortyTwoAddress :: Ledger.Address
fortyTwoAddress = ScriptAddress fortyTwoHash
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type FortyTwoSchema =
type GiftSchema =
BlockchainActions
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" Integer
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToOtherScript fortyTwoHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
ledgerTx <- submitTx 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 fortyTwoHash
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript fortyTwoValidator
Constraints.otherScript validator
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 () FortyTwoSchema Text ()
endpoints :: Contract () GiftSchema Text ()
endpoints = (give' `select` grab') >> endpoints
where
give' = endpoint @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''FortyTwoSchema
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

View file

@ -7,18 +7,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Gift
( give
, grab
, GiftSchema
, endpoints
, schemas
, registeredKnownCurrencies
, printJson
, printSchemas
, ensureKnownCurrencies
, stage
) where
module Week02.Gift where
import Control.Monad hiding (fmap)
import Data.Map as Map
@ -38,18 +27,18 @@ import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
{-# INLINABLE mkGiftValidator #-}
mkGiftValidator :: Data -> Data -> Data -> ()
mkGiftValidator _ _ _ = ()
{-# INLINABLE mkValidator #-}
mkValidator :: Data -> Data -> Data -> ()
mkValidator _ _ _ = ()
giftValidator :: Validator
giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
validator :: Validator
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
giftHash :: Ledger.ValidatorHash
giftHash = Scripts.validatorHash giftValidator
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
giftAddress :: Ledger.Address
giftAddress = ScriptAddress giftHash
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type GiftSchema =
BlockchainActions
@ -58,17 +47,17 @@ type GiftSchema =
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToOtherScript giftHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
let tx = mustPayToOtherScript valHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
ledgerTx <- submitTx tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
grab = do
utxos <- utxoAt $ ScriptAddress giftHash
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript giftValidator
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ I 17 | oref <- orefs]
ledgerTx <- submitTxConstraintsWith @Void lookups tx

View file

@ -0,0 +1,85 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Homework1 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 mkValidator #-}
-- This should validate if and only if the two Booleans in the redeemer are equal!
mkValidator :: () -> (Bool, Bool) -> ValidatorCtx -> Bool
mkValidator _ _ _ = True -- FIX ME!
data Typed
instance Scripts.ScriptType Typed where
-- Implement the instance!
inst :: Scripts.ScriptInstance Typed
inst = undefined -- FIX ME!
validator :: Validator
validator = undefined -- FIX ME!
valHash :: Ledger.ValidatorHash
valHash = undefined -- FIX ME!
scrAddress :: Ledger.Address
scrAddress = undefined -- FIX ME!
type GiftSchema =
BlockchainActions
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" (Bool, Bool)
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
ledgerTx <- submitTxConstraints inst tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => (Bool, Bool) -> Contract w s e ()
grab bs = do
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData bs | 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 @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

View file

@ -0,0 +1,96 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Homework2 where
import Control.Monad hiding (fmap)
import Data.Aeson (FromJSON, ToJSON)
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, ToSchema)
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
data MyRedeemer = MyRedeemer
{ flag1 :: Bool
, flag2 :: Bool
} deriving (Generic, FromJSON, ToJSON, ToSchema)
PlutusTx.unstableMakeIsData ''MyRedeemer
{-# INLINABLE mkValidator #-}
-- This should validate if and only if the two Booleans in the redeemer are equal!
mkValidator :: () -> MyRedeemer -> ValidatorCtx -> Bool
mkValidator _ _ _ = True -- FIX ME!
data Typed
instance Scripts.ScriptType Typed where
-- Implement me!
inst :: Scripts.ScriptInstance Typed
inst = undefined -- FIX ME!
validator :: Validator
validator = undefined -- FIX ME!
valHash :: Ledger.ValidatorHash
valHash = undefined -- FIX ME!
scrAddress :: Ledger.Address
scrAddress = undefined -- FIX ME!
type GiftSchema =
BlockchainActions
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" MyRedeemer
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
ledgerTx <- submitTxConstraints inst tx
void $ awaitTxConfirmed $ txId ledgerTx
logInfo @String $ printf "made a gift of %d lovelace" amount
grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => MyRedeemer -> Contract w s e ()
grab r = do
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData r | 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 @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

View file

@ -0,0 +1,94 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.IsData 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)
newtype MySillyRedeemer = MySillyRedeemer Integer
deriving Show
PlutusTx.unstableMakeIsData ''MySillyRedeemer
{-# INLINABLE mkValidator #-}
mkValidator :: () -> MySillyRedeemer -> ValidatorCtx -> Bool
mkValidator () (MySillyRedeemer r) _ = traceIfFalse "wrong redeemer" $ r == 42
data Typed
instance Scripts.ScriptType Typed where
type instance DatumType Typed = ()
type instance RedeemerType Typed = MySillyRedeemer
inst :: Scripts.ScriptInstance Typed
inst = Scripts.validator @Typed
$$(PlutusTx.compile [|| mkValidator ||])
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator @() @MySillyRedeemer
validator :: Validator
validator = Scripts.validatorScript inst
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type GiftSchema =
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 inst 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 scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript validator
tx :: TxConstraints Void Void
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData $ MySillyRedeemer r | 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 @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []

View file

@ -1,119 +0,0 @@
{-# 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 []

View file

@ -8,18 +8,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week02.Typed
( give
, grab
, TypedSchema
, endpoints
, schemas
, registeredKnownCurrencies
, printJson
, printSchemas
, ensureKnownCurrencies
, stage
) where
module Week02.Typed where
import Control.Monad hiding (fmap)
import Data.Map as Map
@ -40,32 +29,34 @@ import Playground.Types (KnownCurrency (..))
import Prelude (Semigroup (..))
import Text.Printf (printf)
{-# INLINABLE mkTypedValidator #-}
mkTypedValidator :: () -> Integer -> ValidatorCtx -> Bool
mkTypedValidator () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == 42)
{-# INLINABLE mkValidator #-}
mkValidator :: () -> Integer -> ValidatorCtx -> Bool
mkValidator () r _
| r == 42 = True
| otherwise = False
data Typing
instance Scripts.ScriptType Typing where
type instance RedeemerType Typing = Integer
type instance DatumType Typing = ()
data Typed
instance Scripts.ScriptType Typed where
type instance DatumType Typed = ()
type instance RedeemerType Typed = Integer
typedInstance :: Scripts.ScriptInstance Typing
typedInstance = Scripts.validator @Typing
$$(PlutusTx.compile [|| mkTypedValidator ||])
inst :: Scripts.ScriptInstance Typed
inst = Scripts.validator @Typed
$$(PlutusTx.compile [|| mkValidator ||])
$$(PlutusTx.compile [|| wrap ||])
where
wrap = Scripts.wrapValidator @() @Integer
typedValidator :: Validator
typedValidator = Scripts.validatorScript typedInstance
validator :: Validator
validator = Scripts.validatorScript inst
typedHash :: Ledger.ValidatorHash
typedHash = Scripts.validatorHash typedValidator
valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash validator
typedAddress :: Ledger.Address
typedAddress = ScriptAddress typedHash
scrAddress :: Ledger.Address
scrAddress = ScriptAddress valHash
type TypedSchema =
type GiftSchema =
BlockchainActions
.\/ Endpoint "give" Integer
.\/ Endpoint "grab" Integer
@ -73,28 +64,28 @@ type TypedSchema =
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
give amount = do
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
ledgerTx <- submitTxConstraints typedInstance tx
ledgerTx <- submitTxConstraints inst 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
utxos <- utxoAt scrAddress
let orefs = fst <$> Map.toList utxos
lookups = Constraints.unspentOutputs utxos <>
Constraints.otherScript typedValidator
Constraints.otherScript validator
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 :: Contract () GiftSchema Text ()
endpoints = (give' `select` grab') >> endpoints
where
give' = endpoint @"give" >>= give
grab' = endpoint @"grab" >>= grab
mkSchemaDefinitions ''TypedSchema
mkSchemaDefinitions ''GiftSchema
mkKnownCurrencies []