mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-09-21 17:27:56 +02:00
added solutions for week 2
This commit is contained in:
Lars Brünjes
parent
fcba0bba7f
commit
e05f1900ff
4 changed files with 200 additions and 0 deletions
|
|
@ -41,6 +41,13 @@
|
|||
- Fix and complete the code in the [Homework1](code/week02/src/Week02/Homework1.hs) module.
|
||||
- Fix and complete the code in the [Homework2](code/week02/src/Week02/Homework2.hs) module.
|
||||
|
||||
## Solutions
|
||||
|
||||
- Week #2
|
||||
|
||||
- [`Homework1`](code/week02/src/Week02/Solution1.hs)
|
||||
- [`Homework2`](code/week02/src/Week02/Solution2.hs)
|
||||
|
||||
## 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.
|
||||
|
|
|
|||
|
|
@ -16,6 +16,8 @@ library
|
|||
, Week02.Homework2
|
||||
, Week02.Gift
|
||||
, Week02.IsData
|
||||
, Week02.Solution1
|
||||
, Week02.Solution2
|
||||
, Week02.Typed
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
|
|
|
|||
90
code/week02/src/Week02/Solution1.hs
Normal file
90
code/week02/src/Week02/Solution1.hs
Normal file
|
|
@ -0,0 +1,90 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week02.Solution1 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 () (b, c) _ = traceIfFalse "wrong redeemer" $ b == c
|
||||
|
||||
data Typed
|
||||
instance Scripts.ScriptType Typed where
|
||||
type instance DatumType Typed = ()
|
||||
type instance RedeemerType Typed = (Bool, Bool)
|
||||
|
||||
inst :: Scripts.ScriptInstance Typed
|
||||
inst = Scripts.validator @Typed
|
||||
$$(PlutusTx.compile [|| mkValidator ||])
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @() @(Bool, Bool)
|
||||
|
||||
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" (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 []
|
||||
101
code/week02/src/Week02/Solution2.hs
Normal file
101
code/week02/src/Week02/Solution2.hs
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week02.Solution2 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 () (MyRedeemer b c) _ = traceIfFalse "wrong redeemer" $ b == c
|
||||
|
||||
data Typed
|
||||
instance Scripts.ScriptType Typed where
|
||||
type instance DatumType Typed = ()
|
||||
type instance RedeemerType Typed = MyRedeemer
|
||||
|
||||
inst :: Scripts.ScriptInstance Typed
|
||||
inst = Scripts.validator @Typed
|
||||
$$(PlutusTx.compile [|| mkValidator ||])
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @() @MyRedeemer
|
||||
|
||||
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" 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 []
|
||||
Loading…
Reference in a new issue