mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 02:42:35 +01:00
finished code for week 2
This commit is contained in:
parent
a739b2fe6e
commit
0e9277b6f8
10 changed files with 356 additions and 239 deletions
|
@ -31,6 +31,7 @@
|
||||||
## Some Plutus Modules
|
## 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.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
|
## Additional Resources
|
||||||
|
|
||||||
|
|
|
@ -12,8 +12,10 @@ library
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
exposed-modules: Week02.Burn
|
exposed-modules: Week02.Burn
|
||||||
, Week02.FortyTwo
|
, Week02.FortyTwo
|
||||||
|
, Week02.Homework1
|
||||||
|
, Week02.Homework2
|
||||||
, Week02.Gift
|
, Week02.Gift
|
||||||
, Week02.Parameterized
|
, Week02.IsData
|
||||||
, Week02.Typed
|
, Week02.Typed
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
|
|
|
@ -8,18 +8,7 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
module Week02.Burn
|
module Week02.Burn where
|
||||||
( burn
|
|
||||||
, grab
|
|
||||||
, BurnSchema
|
|
||||||
, endpoints
|
|
||||||
, schemas
|
|
||||||
, registeredKnownCurrencies
|
|
||||||
, printJson
|
|
||||||
, printSchemas
|
|
||||||
, ensureKnownCurrencies
|
|
||||||
, stage
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad hiding (fmap)
|
import Control.Monad hiding (fmap)
|
||||||
import Data.Map as Map
|
import Data.Map as Map
|
||||||
|
@ -39,49 +28,49 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkBurnValidator #-}
|
{-# INLINABLE mkValidator #-}
|
||||||
mkBurnValidator :: Data -> Data -> Data -> ()
|
mkValidator :: Data -> Data -> Data -> ()
|
||||||
mkBurnValidator _ _ _ = traceError "NO WAY!"
|
mkValidator _ _ _ = traceError "NO WAY!"
|
||||||
|
|
||||||
burnValidator :: Validator
|
validator :: Validator
|
||||||
burnValidator = mkValidatorScript $$(PlutusTx.compile [|| mkBurnValidator ||])
|
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
|
||||||
burnHash :: Ledger.ValidatorHash
|
valHash :: Ledger.ValidatorHash
|
||||||
burnHash = Scripts.validatorHash burnValidator
|
valHash = Scripts.validatorHash validator
|
||||||
|
|
||||||
burnAddress :: Ledger.Address
|
scrAddress :: Ledger.Address
|
||||||
burnAddress = ScriptAddress burnHash
|
scrAddress = ScriptAddress valHash
|
||||||
|
|
||||||
type BurnSchema =
|
type GiftSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
.\/ Endpoint "burn" Integer
|
.\/ Endpoint "give" Integer
|
||||||
.\/ Endpoint "grab" ()
|
.\/ Endpoint "grab" ()
|
||||||
|
|
||||||
burn :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
give :: (HasBlockchainActions s, AsContractError e) => Integer -> Contract w s e ()
|
||||||
burn amount = do
|
give amount = do
|
||||||
let tx = mustPayToOtherScript burnHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
|
let tx = mustPayToOtherScript valHash (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 "made a gift of %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 burnHash
|
utxos <- utxoAt scrAddress
|
||||||
let orefs = fst <$> Map.toList utxos
|
let orefs = fst <$> Map.toList utxos
|
||||||
lookups = Constraints.unspentOutputs utxos <>
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
Constraints.otherScript burnValidator
|
Constraints.otherScript validator
|
||||||
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
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ "collected gifts"
|
logInfo @String $ "collected gifts"
|
||||||
|
|
||||||
endpoints :: Contract () BurnSchema Text ()
|
endpoints :: Contract () GiftSchema Text ()
|
||||||
endpoints = (give' `select` grab') >> endpoints
|
endpoints = (give' `select` grab') >> endpoints
|
||||||
where
|
where
|
||||||
give' = endpoint @"burn" >>= burn
|
give' = endpoint @"give" >>= give
|
||||||
grab' = endpoint @"grab" >> grab
|
grab' = endpoint @"grab" >> grab
|
||||||
|
|
||||||
mkSchemaDefinitions ''BurnSchema
|
mkSchemaDefinitions ''GiftSchema
|
||||||
|
|
||||||
mkKnownCurrencies []
|
mkKnownCurrencies []
|
||||||
|
|
|
@ -8,18 +8,7 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
module Week02.FortyTwo
|
module Week02.FortyTwo where
|
||||||
( give
|
|
||||||
, grab
|
|
||||||
, FortyTwoSchema
|
|
||||||
, endpoints
|
|
||||||
, schemas
|
|
||||||
, registeredKnownCurrencies
|
|
||||||
, printJson
|
|
||||||
, printSchemas
|
|
||||||
, ensureKnownCurrencies
|
|
||||||
, stage
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad hiding (fmap)
|
import Control.Monad hiding (fmap)
|
||||||
import Data.Map as Map
|
import Data.Map as Map
|
||||||
|
@ -39,51 +28,51 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkFortyTwoValidator #-}
|
{-# INLINABLE mkValidator #-}
|
||||||
mkFortyTwoValidator :: Data -> Data -> Data -> ()
|
mkValidator :: Data -> Data -> Data -> ()
|
||||||
mkFortyTwoValidator _ (I n) _
|
mkValidator _ r _
|
||||||
| n == 42 = ()
|
| r == I 42 = ()
|
||||||
mkFortyTwoValidator _ _ _ = traceError "UNEXPECTED REDEEMER!"
|
| otherwise = traceError "wrong redeemer"
|
||||||
|
|
||||||
fortyTwoValidator :: Validator
|
validator :: Validator
|
||||||
fortyTwoValidator = mkValidatorScript $$(PlutusTx.compile [|| mkFortyTwoValidator ||])
|
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
|
||||||
fortyTwoHash :: Ledger.ValidatorHash
|
valHash :: Ledger.ValidatorHash
|
||||||
fortyTwoHash = Scripts.validatorHash fortyTwoValidator
|
valHash = Scripts.validatorHash validator
|
||||||
|
|
||||||
fortyTwoAddress :: Ledger.Address
|
scrAddress :: Ledger.Address
|
||||||
fortyTwoAddress = ScriptAddress fortyTwoHash
|
scrAddress = ScriptAddress valHash
|
||||||
|
|
||||||
type FortyTwoSchema =
|
type GiftSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
.\/ Endpoint "give" Integer
|
.\/ Endpoint "give" Integer
|
||||||
.\/ Endpoint "grab" Integer
|
.\/ Endpoint "grab" Integer
|
||||||
|
|
||||||
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 fortyTwoHash (Datum $ Constr 0 []) $ Ada.lovelaceValueOf amount
|
let tx = mustPayToOtherScript valHash (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 fortyTwoHash
|
utxos <- utxoAt scrAddress
|
||||||
let orefs = fst <$> Map.toList utxos
|
let orefs = fst <$> Map.toList utxos
|
||||||
lookups = Constraints.unspentOutputs utxos <>
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
Constraints.otherScript fortyTwoValidator
|
Constraints.otherScript validator
|
||||||
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
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ "collected gifts"
|
logInfo @String $ "collected gifts"
|
||||||
|
|
||||||
endpoints :: Contract () FortyTwoSchema Text ()
|
endpoints :: Contract () GiftSchema Text ()
|
||||||
endpoints = (give' `select` grab') >> endpoints
|
endpoints = (give' `select` grab') >> endpoints
|
||||||
where
|
where
|
||||||
give' = endpoint @"give" >>= give
|
give' = endpoint @"give" >>= give
|
||||||
grab' = endpoint @"grab" >>= grab
|
grab' = endpoint @"grab" >>= grab
|
||||||
|
|
||||||
mkSchemaDefinitions ''FortyTwoSchema
|
mkSchemaDefinitions ''GiftSchema
|
||||||
|
|
||||||
mkKnownCurrencies []
|
mkKnownCurrencies []
|
||||||
|
|
|
@ -7,18 +7,7 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
module Week02.Gift
|
module Week02.Gift where
|
||||||
( give
|
|
||||||
, grab
|
|
||||||
, GiftSchema
|
|
||||||
, endpoints
|
|
||||||
, schemas
|
|
||||||
, registeredKnownCurrencies
|
|
||||||
, printJson
|
|
||||||
, printSchemas
|
|
||||||
, ensureKnownCurrencies
|
|
||||||
, stage
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad hiding (fmap)
|
import Control.Monad hiding (fmap)
|
||||||
import Data.Map as Map
|
import Data.Map as Map
|
||||||
|
@ -38,18 +27,18 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkGiftValidator #-}
|
{-# INLINABLE mkValidator #-}
|
||||||
mkGiftValidator :: Data -> Data -> Data -> ()
|
mkValidator :: Data -> Data -> Data -> ()
|
||||||
mkGiftValidator _ _ _ = ()
|
mkValidator _ _ _ = ()
|
||||||
|
|
||||||
giftValidator :: Validator
|
validator :: Validator
|
||||||
giftValidator = mkValidatorScript $$(PlutusTx.compile [|| mkGiftValidator ||])
|
validator = mkValidatorScript $$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
|
||||||
giftHash :: Ledger.ValidatorHash
|
valHash :: Ledger.ValidatorHash
|
||||||
giftHash = Scripts.validatorHash giftValidator
|
valHash = Scripts.validatorHash validator
|
||||||
|
|
||||||
giftAddress :: Ledger.Address
|
scrAddress :: Ledger.Address
|
||||||
giftAddress = ScriptAddress giftHash
|
scrAddress = ScriptAddress valHash
|
||||||
|
|
||||||
type GiftSchema =
|
type GiftSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
|
@ -58,17 +47,17 @@ type GiftSchema =
|
||||||
|
|
||||||
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 valHash (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) => 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 scrAddress
|
||||||
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 validator
|
||||||
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
|
||||||
|
|
85
code/week02/src/Week02/Homework1.hs
Normal file
85
code/week02/src/Week02/Homework1.hs
Normal 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 []
|
96
code/week02/src/Week02/Homework2.hs
Normal file
96
code/week02/src/Week02/Homework2.hs
Normal 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 []
|
94
code/week02/src/Week02/IsData.hs
Normal file
94
code/week02/src/Week02/IsData.hs
Normal 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 []
|
|
@ -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 []
|
|
|
@ -8,18 +8,7 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
module Week02.Typed
|
module Week02.Typed where
|
||||||
( give
|
|
||||||
, grab
|
|
||||||
, TypedSchema
|
|
||||||
, endpoints
|
|
||||||
, schemas
|
|
||||||
, registeredKnownCurrencies
|
|
||||||
, printJson
|
|
||||||
, printSchemas
|
|
||||||
, ensureKnownCurrencies
|
|
||||||
, stage
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad hiding (fmap)
|
import Control.Monad hiding (fmap)
|
||||||
import Data.Map as Map
|
import Data.Map as Map
|
||||||
|
@ -40,32 +29,34 @@ import Playground.Types (KnownCurrency (..))
|
||||||
import Prelude (Semigroup (..))
|
import Prelude (Semigroup (..))
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
{-# INLINABLE mkTypedValidator #-}
|
{-# INLINABLE mkValidator #-}
|
||||||
mkTypedValidator :: () -> Integer -> ValidatorCtx -> Bool
|
mkValidator :: () -> Integer -> ValidatorCtx -> Bool
|
||||||
mkTypedValidator () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == 42)
|
mkValidator () r _
|
||||||
|
| r == 42 = True
|
||||||
|
| otherwise = False
|
||||||
|
|
||||||
data Typing
|
data Typed
|
||||||
instance Scripts.ScriptType Typing where
|
instance Scripts.ScriptType Typed where
|
||||||
type instance RedeemerType Typing = Integer
|
type instance DatumType Typed = ()
|
||||||
type instance DatumType Typing = ()
|
type instance RedeemerType Typed = Integer
|
||||||
|
|
||||||
typedInstance :: Scripts.ScriptInstance Typing
|
inst :: Scripts.ScriptInstance Typed
|
||||||
typedInstance = Scripts.validator @Typing
|
inst = Scripts.validator @Typed
|
||||||
$$(PlutusTx.compile [|| mkTypedValidator ||])
|
$$(PlutusTx.compile [|| mkValidator ||])
|
||||||
$$(PlutusTx.compile [|| wrap ||])
|
$$(PlutusTx.compile [|| wrap ||])
|
||||||
where
|
where
|
||||||
wrap = Scripts.wrapValidator @() @Integer
|
wrap = Scripts.wrapValidator @() @Integer
|
||||||
|
|
||||||
typedValidator :: Validator
|
validator :: Validator
|
||||||
typedValidator = Scripts.validatorScript typedInstance
|
validator = Scripts.validatorScript inst
|
||||||
|
|
||||||
typedHash :: Ledger.ValidatorHash
|
valHash :: Ledger.ValidatorHash
|
||||||
typedHash = Scripts.validatorHash typedValidator
|
valHash = Scripts.validatorHash validator
|
||||||
|
|
||||||
typedAddress :: Ledger.Address
|
scrAddress :: Ledger.Address
|
||||||
typedAddress = ScriptAddress typedHash
|
scrAddress = ScriptAddress valHash
|
||||||
|
|
||||||
type TypedSchema =
|
type GiftSchema =
|
||||||
BlockchainActions
|
BlockchainActions
|
||||||
.\/ Endpoint "give" Integer
|
.\/ Endpoint "give" Integer
|
||||||
.\/ Endpoint "grab" Integer
|
.\/ Endpoint "grab" Integer
|
||||||
|
@ -73,28 +64,28 @@ type TypedSchema =
|
||||||
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 = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
||||||
ledgerTx <- submitTxConstraints typedInstance tx
|
ledgerTx <- submitTxConstraints inst 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 typedHash
|
utxos <- utxoAt scrAddress
|
||||||
let orefs = fst <$> Map.toList utxos
|
let orefs = fst <$> Map.toList utxos
|
||||||
lookups = Constraints.unspentOutputs utxos <>
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
Constraints.otherScript typedValidator
|
Constraints.otherScript validator
|
||||||
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
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
logInfo @String $ "collected gifts"
|
logInfo @String $ "collected gifts"
|
||||||
|
|
||||||
endpoints :: Contract () TypedSchema Text ()
|
endpoints :: Contract () GiftSchema Text ()
|
||||||
endpoints = (give' `select` grab') >> endpoints
|
endpoints = (give' `select` grab') >> endpoints
|
||||||
where
|
where
|
||||||
give' = endpoint @"give" >>= give
|
give' = endpoint @"give" >>= give
|
||||||
grab' = endpoint @"grab" >>= grab
|
grab' = endpoint @"grab" >>= grab
|
||||||
|
|
||||||
mkSchemaDefinitions ''TypedSchema
|
mkSchemaDefinitions ''GiftSchema
|
||||||
|
|
||||||
mkKnownCurrencies []
|
mkKnownCurrencies []
|
||||||
|
|
Loading…
Reference in a new issue