mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 02:42:35 +01:00
added old solutions
This commit is contained in:
parent
1d223b2206
commit
b9736840bb
11 changed files with 722 additions and 0 deletions
|
@ -16,6 +16,8 @@ library
|
||||||
, Week02.Homework2
|
, Week02.Homework2
|
||||||
, Week02.Gift
|
, Week02.Gift
|
||||||
, Week02.IsData
|
, Week02.IsData
|
||||||
|
, Week02.Solution1
|
||||||
|
, Week02.Solution2
|
||||||
, Week02.Typed
|
, Week02.Typed
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
|
|
91
code/week02/src/Week02/Solution1.hs
Normal file
91
code/week02/src/Week02/Solution1.hs
Normal file
|
@ -0,0 +1,91 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||||
|
|
||||||
|
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
|
||||||
|
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 hiding (validatorHash)
|
||||||
|
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 (IO, Semigroup (..), String)
|
||||||
|
import Text.Printf (printf)
|
||||||
|
|
||||||
|
{-# INLINABLE mkValidator #-}
|
||||||
|
-- This should validate if and only if the two Booleans in the redeemer are equal!
|
||||||
|
mkValidator :: () -> (Bool, Bool) -> ScriptContext -> Bool
|
||||||
|
mkValidator () (b, c) _ = traceIfFalse "wrong redeemer" $ b == c
|
||||||
|
|
||||||
|
data Typed
|
||||||
|
instance Scripts.ValidatorTypes Typed where
|
||||||
|
type instance DatumType Typed = ()
|
||||||
|
type instance RedeemerType Typed = (Bool, Bool)
|
||||||
|
|
||||||
|
typedValidator :: Scripts.TypedValidator Typed
|
||||||
|
typedValidator = Scripts.mkTypedValidator @Typed
|
||||||
|
$$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
$$(PlutusTx.compile [|| wrap ||])
|
||||||
|
where
|
||||||
|
wrap = Scripts.wrapValidator @() @(Bool, Bool)
|
||||||
|
|
||||||
|
validator :: Validator
|
||||||
|
validator = Scripts.validatorScript typedValidator
|
||||||
|
|
||||||
|
valHash :: Ledger.ValidatorHash
|
||||||
|
valHash = Scripts.validatorHash typedValidator
|
||||||
|
|
||||||
|
scrAddress :: Ledger.Address
|
||||||
|
scrAddress = scriptAddress validator
|
||||||
|
|
||||||
|
type GiftSchema =
|
||||||
|
Endpoint "give" Integer
|
||||||
|
.\/ Endpoint "grab" (Bool, Bool)
|
||||||
|
|
||||||
|
give :: AsContractError e => Integer -> Contract w s e ()
|
||||||
|
give amount = do
|
||||||
|
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
||||||
|
ledgerTx <- submitTxConstraints typedValidator tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
logInfo @String $ printf "made a gift of %d lovelace" amount
|
||||||
|
|
||||||
|
grab :: forall w s e. 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 []
|
100
code/week02/src/Week02/Solution2.hs
Normal file
100
code/week02/src/Week02/Solution2.hs
Normal file
|
@ -0,0 +1,100 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||||
|
|
||||||
|
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
|
||||||
|
import qualified PlutusTx
|
||||||
|
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||||
|
import Ledger hiding (singleton)
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
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 (IO, Semigroup (..), String)
|
||||||
|
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 -> ScriptContext -> Bool
|
||||||
|
mkValidator () (MyRedeemer b c) _ = traceIfFalse "wrong redeemer" $ b == c
|
||||||
|
|
||||||
|
data Typed
|
||||||
|
instance Scripts.ValidatorTypes Typed where
|
||||||
|
type instance DatumType Typed = ()
|
||||||
|
type instance RedeemerType Typed = MyRedeemer
|
||||||
|
|
||||||
|
typedValidator :: Scripts.TypedValidator Typed
|
||||||
|
typedValidator = Scripts.mkTypedValidator @Typed
|
||||||
|
$$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
$$(PlutusTx.compile [|| wrap ||])
|
||||||
|
where
|
||||||
|
wrap = Scripts.wrapValidator @() @MyRedeemer
|
||||||
|
|
||||||
|
validator :: Validator
|
||||||
|
validator = Scripts.validatorScript typedValidator
|
||||||
|
|
||||||
|
valHash :: Ledger.ValidatorHash
|
||||||
|
valHash = Scripts.validatorHash typedValidator
|
||||||
|
|
||||||
|
scrAddress :: Ledger.Address
|
||||||
|
scrAddress = scriptAddress validator
|
||||||
|
|
||||||
|
type GiftSchema =
|
||||||
|
Endpoint "give" Integer
|
||||||
|
.\/ Endpoint "grab" MyRedeemer
|
||||||
|
|
||||||
|
give :: AsContractError e => Integer -> Contract w s e ()
|
||||||
|
give amount = do
|
||||||
|
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
||||||
|
ledgerTx <- submitTxConstraints typedValidator tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
logInfo @String $ printf "made a gift of %d lovelace" amount
|
||||||
|
|
||||||
|
grab :: forall w s e. 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 []
|
|
@ -13,6 +13,8 @@ library
|
||||||
exposed-modules: Week03.Homework1
|
exposed-modules: Week03.Homework1
|
||||||
, Week03.Homework2
|
, Week03.Homework2
|
||||||
, Week03.Parameterized
|
, Week03.Parameterized
|
||||||
|
, Week03.Solution1
|
||||||
|
, Week03.Solution2
|
||||||
, Week03.Vesting
|
, Week03.Vesting
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
|
|
145
code/week03/src/Week03/Solution1.hs
Normal file
145
code/week03/src/Week03/Solution1.hs
Normal file
|
@ -0,0 +1,145 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||||
|
|
||||||
|
module Week03.Solution1 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
|
||||||
|
import qualified PlutusTx
|
||||||
|
import PlutusTx.Prelude hiding (unless)
|
||||||
|
import Ledger hiding (singleton)
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
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 (IO, Show (..), String)
|
||||||
|
import qualified Prelude as P
|
||||||
|
import Text.Printf (printf)
|
||||||
|
|
||||||
|
data VestingDatum = VestingDatum
|
||||||
|
{ beneficiary1 :: PubKeyHash
|
||||||
|
, beneficiary2 :: PubKeyHash
|
||||||
|
, deadline :: POSIXTime
|
||||||
|
} deriving Show
|
||||||
|
|
||||||
|
PlutusTx.unstableMakeIsData ''VestingDatum
|
||||||
|
|
||||||
|
{-# INLINABLE mkValidator #-}
|
||||||
|
mkValidator :: VestingDatum -> () -> ScriptContext -> Bool
|
||||||
|
mkValidator dat () ctx
|
||||||
|
| (beneficiary1 dat `elem` sigs) && (to (deadline dat) `contains` range) = True
|
||||||
|
| (beneficiary2 dat `elem` sigs) && (from (1 + deadline dat) `contains` range) = True
|
||||||
|
| otherwise = False
|
||||||
|
where
|
||||||
|
info :: TxInfo
|
||||||
|
info = scriptContextTxInfo ctx
|
||||||
|
|
||||||
|
sigs :: [PubKeyHash]
|
||||||
|
sigs = txInfoSignatories info
|
||||||
|
|
||||||
|
range :: POSIXTimeRange
|
||||||
|
range = txInfoValidRange info
|
||||||
|
|
||||||
|
data Vesting
|
||||||
|
instance Scripts.ValidatorTypes Vesting where
|
||||||
|
type instance DatumType Vesting = VestingDatum
|
||||||
|
type instance RedeemerType Vesting = ()
|
||||||
|
|
||||||
|
typedValidator :: Scripts.TypedValidator Vesting
|
||||||
|
typedValidator = Scripts.mkTypedValidator @Vesting
|
||||||
|
$$(PlutusTx.compile [|| mkValidator ||])
|
||||||
|
$$(PlutusTx.compile [|| wrap ||])
|
||||||
|
where
|
||||||
|
wrap = Scripts.wrapValidator @VestingDatum @()
|
||||||
|
|
||||||
|
validator :: Validator
|
||||||
|
validator = Scripts.validatorScript typedValidator
|
||||||
|
|
||||||
|
scrAddress :: Ledger.Address
|
||||||
|
scrAddress = scriptAddress validator
|
||||||
|
|
||||||
|
data GiveParams = GiveParams
|
||||||
|
{ gpBeneficiary :: !PubKeyHash
|
||||||
|
, gpDeadline :: !POSIXTime
|
||||||
|
, gpAmount :: !Integer
|
||||||
|
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||||
|
|
||||||
|
type VestingSchema =
|
||||||
|
Endpoint "give" GiveParams
|
||||||
|
.\/ Endpoint "grab" ()
|
||||||
|
|
||||||
|
give :: AsContractError e => GiveParams -> Contract w s e ()
|
||||||
|
give gp = do
|
||||||
|
pkh <- pubKeyHash <$> ownPubKey
|
||||||
|
let dat = VestingDatum
|
||||||
|
{ beneficiary1 = gpBeneficiary gp
|
||||||
|
, beneficiary2 = pkh
|
||||||
|
, deadline = gpDeadline gp
|
||||||
|
}
|
||||||
|
tx = mustPayToTheScript dat $ Ada.lovelaceValueOf $ gpAmount gp
|
||||||
|
ledgerTx <- submitTxConstraints typedValidator tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s"
|
||||||
|
(gpAmount gp)
|
||||||
|
(show $ gpBeneficiary gp)
|
||||||
|
(show $ gpDeadline gp)
|
||||||
|
|
||||||
|
grab :: forall w s e. AsContractError e => Contract w s e ()
|
||||||
|
grab = do
|
||||||
|
now <- currentTime
|
||||||
|
pkh <- pubKeyHash <$> ownPubKey
|
||||||
|
utxos <- utxoAt scrAddress
|
||||||
|
let utxos1 = Map.filter (isSuitable $ \dat -> beneficiary1 dat == pkh && now <= deadline dat) utxos
|
||||||
|
utxos2 = Map.filter (isSuitable $ \dat -> beneficiary2 dat == pkh && now > deadline dat) utxos
|
||||||
|
logInfo @String $ printf "found %d gift(s) to grab" (Map.size utxos1 P.+ Map.size utxos2)
|
||||||
|
unless (Map.null utxos1) $ do
|
||||||
|
let orefs = fst <$> Map.toList utxos1
|
||||||
|
lookups = Constraints.unspentOutputs utxos1 P.<>
|
||||||
|
Constraints.otherScript validator
|
||||||
|
tx :: TxConstraints Void Void
|
||||||
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<>
|
||||||
|
mustValidateIn (to now)
|
||||||
|
void $ submitTxConstraintsWith @Void lookups tx
|
||||||
|
unless (Map.null utxos2) $ do
|
||||||
|
let orefs = fst <$> Map.toList utxos2
|
||||||
|
lookups = Constraints.unspentOutputs utxos2 P.<>
|
||||||
|
Constraints.otherScript validator
|
||||||
|
tx :: TxConstraints Void Void
|
||||||
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] P.<>
|
||||||
|
mustValidateIn (from now)
|
||||||
|
void $ submitTxConstraintsWith @Void lookups tx
|
||||||
|
where
|
||||||
|
isSuitable :: (VestingDatum -> Bool) -> TxOutTx -> Bool
|
||||||
|
isSuitable p o = case txOutDatumHash $ txOutTxOut o of
|
||||||
|
Nothing -> False
|
||||||
|
Just h -> case Map.lookup h $ txData $ txOutTxTx o of
|
||||||
|
Nothing -> False
|
||||||
|
Just (Datum e) -> maybe False p $ PlutusTx.fromData e
|
||||||
|
|
||||||
|
endpoints :: Contract () VestingSchema Text ()
|
||||||
|
endpoints = (give' `select` grab') >> endpoints
|
||||||
|
where
|
||||||
|
give' = endpoint @"give" >>= give
|
||||||
|
grab' = endpoint @"grab" >> grab
|
||||||
|
|
||||||
|
mkSchemaDefinitions ''VestingSchema
|
||||||
|
|
||||||
|
mkKnownCurrencies []
|
127
code/week03/src/Week03/Solution2.hs
Normal file
127
code/week03/src/Week03/Solution2.hs
Normal file
|
@ -0,0 +1,127 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
||||||
|
|
||||||
|
module Week03.Solution2 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
|
||||||
|
import qualified PlutusTx
|
||||||
|
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||||
|
import Ledger hiding (singleton)
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
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 (IO, Semigroup (..), Show (..), String)
|
||||||
|
import Text.Printf (printf)
|
||||||
|
|
||||||
|
{-# INLINABLE mkValidator #-}
|
||||||
|
mkValidator :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
|
||||||
|
mkValidator pkh s () ctx =
|
||||||
|
traceIfFalse "beneficiary's signature missing" checkSig &&
|
||||||
|
traceIfFalse "deadline not reached" checkDeadline
|
||||||
|
where
|
||||||
|
info :: TxInfo
|
||||||
|
info = scriptContextTxInfo ctx
|
||||||
|
|
||||||
|
checkSig :: Bool
|
||||||
|
checkSig = pkh `elem` txInfoSignatories info
|
||||||
|
|
||||||
|
checkDeadline :: Bool
|
||||||
|
checkDeadline = from s `contains` txInfoValidRange info
|
||||||
|
|
||||||
|
data Vesting
|
||||||
|
instance Scripts.ValidatorTypes Vesting where
|
||||||
|
type instance DatumType Vesting = POSIXTime
|
||||||
|
type instance RedeemerType Vesting = ()
|
||||||
|
|
||||||
|
typedValidator :: PubKeyHash -> Scripts.TypedValidator Vesting
|
||||||
|
typedValidator p = Scripts.mkTypedValidator @Vesting
|
||||||
|
($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p)
|
||||||
|
$$(PlutusTx.compile [|| wrap ||])
|
||||||
|
where
|
||||||
|
wrap = Scripts.wrapValidator @POSIXTime @()
|
||||||
|
|
||||||
|
validator :: PubKeyHash -> Validator
|
||||||
|
validator = Scripts.validatorScript . typedValidator
|
||||||
|
|
||||||
|
scrAddress :: PubKeyHash -> Ledger.Address
|
||||||
|
scrAddress = scriptAddress . validator
|
||||||
|
|
||||||
|
data GiveParams = GiveParams
|
||||||
|
{ gpBeneficiary :: !PubKeyHash
|
||||||
|
, gpDeadline :: !POSIXTime
|
||||||
|
, gpAmount :: !Integer
|
||||||
|
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||||
|
|
||||||
|
type VestingSchema =
|
||||||
|
Endpoint "give" GiveParams
|
||||||
|
.\/ Endpoint "grab" ()
|
||||||
|
|
||||||
|
give :: AsContractError e => GiveParams -> Contract w s e ()
|
||||||
|
give gp = do
|
||||||
|
let p = gpBeneficiary gp
|
||||||
|
d = gpDeadline gp
|
||||||
|
tx = mustPayToTheScript d $ Ada.lovelaceValueOf $ gpAmount gp
|
||||||
|
ledgerTx <- submitTxConstraints (typedValidator p) tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
logInfo @String $ printf "made a gift of %d lovelace to %s with deadline %s"
|
||||||
|
(gpAmount gp)
|
||||||
|
(show $ gpBeneficiary gp)
|
||||||
|
(show $ gpDeadline gp)
|
||||||
|
|
||||||
|
grab :: forall w s e. AsContractError e => Contract w s e ()
|
||||||
|
grab = do
|
||||||
|
now <- currentTime
|
||||||
|
pkh <- pubKeyHash <$> ownPubKey
|
||||||
|
utxos <- Map.filter (isSuitable now) <$> utxoAt (scrAddress pkh)
|
||||||
|
if Map.null utxos
|
||||||
|
then logInfo @String $ "no gifts available"
|
||||||
|
else do
|
||||||
|
let orefs = fst <$> Map.toList utxos
|
||||||
|
lookups = Constraints.unspentOutputs utxos <>
|
||||||
|
Constraints.otherScript (validator pkh)
|
||||||
|
tx :: TxConstraints Void Void
|
||||||
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData () | oref <- orefs] <>
|
||||||
|
mustValidateIn (from now)
|
||||||
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
logInfo @String $ "collected gifts"
|
||||||
|
where
|
||||||
|
isSuitable :: POSIXTime -> TxOutTx -> Bool
|
||||||
|
isSuitable now o = case txOutDatumHash $ txOutTxOut o of
|
||||||
|
Nothing -> False
|
||||||
|
Just h -> case Map.lookup h $ txData $ txOutTxTx o of
|
||||||
|
Nothing -> False
|
||||||
|
Just (Datum e) -> case PlutusTx.fromData e of
|
||||||
|
Nothing -> False
|
||||||
|
Just d -> d <= now
|
||||||
|
|
||||||
|
endpoints :: Contract () VestingSchema Text ()
|
||||||
|
endpoints = (give' `select` grab') >> endpoints
|
||||||
|
where
|
||||||
|
give' = endpoint @"give" >>= give
|
||||||
|
grab' = endpoint @"grab" >> grab
|
||||||
|
|
||||||
|
mkSchemaDefinitions ''VestingSchema
|
||||||
|
|
||||||
|
mkKnownCurrencies []
|
|
@ -15,6 +15,7 @@ library
|
||||||
, Week04.Homework
|
, Week04.Homework
|
||||||
, Week04.Maybe
|
, Week04.Maybe
|
||||||
, Week04.Monad
|
, Week04.Monad
|
||||||
|
, Week04.Solution
|
||||||
, Week04.Trace
|
, Week04.Trace
|
||||||
, Week04.Writer
|
, Week04.Writer
|
||||||
other-modules: Week04.Vesting
|
other-modules: Week04.Vesting
|
||||||
|
|
54
code/week04/src/Week04/Solution.hs
Normal file
54
code/week04/src/Week04/Solution.hs
Normal file
|
@ -0,0 +1,54 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Week04.Solution where
|
||||||
|
|
||||||
|
import Data.Aeson (FromJSON, ToJSON)
|
||||||
|
import Data.Functor (void)
|
||||||
|
import Data.Text (Text, unpack)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Ledger
|
||||||
|
import Ledger.Ada as Ada
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
import Plutus.Contract as Contract
|
||||||
|
import Plutus.Trace.Emulator as Emulator
|
||||||
|
import Wallet.Emulator.Wallet
|
||||||
|
|
||||||
|
data PayParams = PayParams
|
||||||
|
{ ppRecipient :: PubKeyHash
|
||||||
|
, ppLovelace :: Integer
|
||||||
|
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||||
|
|
||||||
|
type PaySchema = Endpoint "pay" PayParams
|
||||||
|
|
||||||
|
payContract :: Contract () PaySchema Text ()
|
||||||
|
payContract = do
|
||||||
|
pp <- endpoint @"pay"
|
||||||
|
let tx = mustPayToPubKey (ppRecipient pp) $ lovelaceValueOf $ ppLovelace pp
|
||||||
|
handleError (\err -> Contract.logInfo $ "caught error: " ++ unpack err) $ void $ submitTx tx
|
||||||
|
payContract
|
||||||
|
|
||||||
|
payTrace :: Integer -> Integer -> EmulatorTrace ()
|
||||||
|
payTrace x y = do
|
||||||
|
h <- activateContractWallet (Wallet 1) payContract
|
||||||
|
let pkh = pubKeyHash $ walletPubKey $ Wallet 2
|
||||||
|
callEndpoint @"pay" h $ PayParams
|
||||||
|
{ ppRecipient = pkh
|
||||||
|
, ppLovelace = x
|
||||||
|
}
|
||||||
|
void $ Emulator.waitNSlots 1
|
||||||
|
callEndpoint @"pay" h $ PayParams
|
||||||
|
{ ppRecipient = pkh
|
||||||
|
, ppLovelace = y
|
||||||
|
}
|
||||||
|
void $ Emulator.waitNSlots 1
|
||||||
|
|
||||||
|
payTest1 :: IO ()
|
||||||
|
payTest1 = runEmulatorTraceIO $ payTrace 1000000 2000000
|
||||||
|
|
||||||
|
payTest2 :: IO ()
|
||||||
|
payTest2 = runEmulatorTraceIO $ payTrace 1000000000 2000000
|
|
@ -15,6 +15,8 @@ library
|
||||||
, Week05.Homework2
|
, Week05.Homework2
|
||||||
, Week05.NFT
|
, Week05.NFT
|
||||||
, Week05.Signed
|
, Week05.Signed
|
||||||
|
, Week05.Solution1
|
||||||
|
, Week05.Solution2
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
, containers
|
, containers
|
||||||
|
|
104
code/week05/src/Week05/Solution1.hs
Normal file
104
code/week05/src/Week05/Solution1.hs
Normal file
|
@ -0,0 +1,104 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Week05.Solution1 where
|
||||||
|
|
||||||
|
import Control.Monad hiding (fmap)
|
||||||
|
import Data.Aeson (ToJSON, FromJSON)
|
||||||
|
import Data.Default (Default (..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Void (Void)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Plutus.Contract as Contract
|
||||||
|
import Plutus.Trace.Emulator as Emulator
|
||||||
|
import qualified PlutusTx
|
||||||
|
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||||
|
import Ledger hiding (mint, singleton)
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
import Ledger.TimeSlot
|
||||||
|
import qualified Ledger.Typed.Scripts as Scripts
|
||||||
|
import Ledger.Value as Value
|
||||||
|
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||||
|
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||||
|
import Playground.Types (KnownCurrency (..))
|
||||||
|
import Prelude (IO, Semigroup (..), Show (..), String)
|
||||||
|
import Text.Printf (printf)
|
||||||
|
import Wallet.Emulator.Wallet
|
||||||
|
|
||||||
|
{-# INLINABLE mkPolicy #-}
|
||||||
|
mkPolicy :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
|
||||||
|
mkPolicy pkh deadline () ctx =
|
||||||
|
traceIfFalse "signature missing" (txSignedBy info pkh) &&
|
||||||
|
traceIfFalse "deadline missed" (to deadline `contains` txInfoValidRange info)
|
||||||
|
where
|
||||||
|
info = scriptContextTxInfo ctx
|
||||||
|
|
||||||
|
policy :: PubKeyHash -> POSIXTime -> Scripts.MintingPolicy
|
||||||
|
policy pkh deadline = mkMintingPolicyScript $
|
||||||
|
$$(PlutusTx.compile [|| \pkh' deadline' -> Scripts.wrapMintingPolicy $ mkPolicy pkh' deadline' ||])
|
||||||
|
`PlutusTx.applyCode`
|
||||||
|
PlutusTx.liftCode pkh
|
||||||
|
`PlutusTx.applyCode`
|
||||||
|
PlutusTx.liftCode deadline
|
||||||
|
|
||||||
|
curSymbol :: PubKeyHash -> POSIXTime -> CurrencySymbol
|
||||||
|
curSymbol pkh deadline = scriptCurrencySymbol $ policy pkh deadline
|
||||||
|
|
||||||
|
data MintParams = MintParams
|
||||||
|
{ mpTokenName :: !TokenName
|
||||||
|
, mpDeadline :: !POSIXTime
|
||||||
|
, mpAmount :: !Integer
|
||||||
|
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||||
|
|
||||||
|
type SignedSchema = Endpoint "mint" MintParams
|
||||||
|
|
||||||
|
mint :: MintParams -> Contract w SignedSchema Text ()
|
||||||
|
mint mp = do
|
||||||
|
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||||
|
now <- Contract.currentTime
|
||||||
|
let deadline = mpDeadline mp
|
||||||
|
if now > deadline
|
||||||
|
then Contract.logError @String "deadline passed"
|
||||||
|
else do
|
||||||
|
let val = Value.singleton (curSymbol pkh deadline) (mpTokenName mp) (mpAmount mp)
|
||||||
|
lookups = Constraints.mintingPolicy $ policy pkh deadline
|
||||||
|
tx = Constraints.mustMintValue val <> Constraints.mustValidateIn (to $ now + 5000)
|
||||||
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
Contract.logInfo @String $ printf "forged %s" (show val)
|
||||||
|
|
||||||
|
endpoints :: Contract () SignedSchema Text ()
|
||||||
|
endpoints = mint' >> endpoints
|
||||||
|
where
|
||||||
|
mint' = endpoint @"mint" >>= mint
|
||||||
|
|
||||||
|
mkSchemaDefinitions ''SignedSchema
|
||||||
|
|
||||||
|
mkKnownCurrencies []
|
||||||
|
|
||||||
|
test :: IO ()
|
||||||
|
test = runEmulatorTraceIO $ do
|
||||||
|
let tn = "ABC"
|
||||||
|
deadline = slotToBeginPOSIXTime def 10
|
||||||
|
h <- activateContractWallet (Wallet 1) endpoints
|
||||||
|
callEndpoint @"mint" h $ MintParams
|
||||||
|
{ mpTokenName = tn
|
||||||
|
, mpDeadline = deadline
|
||||||
|
, mpAmount = 555
|
||||||
|
}
|
||||||
|
void $ Emulator.waitNSlots 15
|
||||||
|
callEndpoint @"mint" h $ MintParams
|
||||||
|
{ mpTokenName = tn
|
||||||
|
, mpDeadline = deadline
|
||||||
|
, mpAmount = 555
|
||||||
|
}
|
||||||
|
void $ Emulator.waitNSlots 1
|
94
code/week05/src/Week05/Solution2.hs
Normal file
94
code/week05/src/Week05/Solution2.hs
Normal file
|
@ -0,0 +1,94 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Week05.Solution2 where
|
||||||
|
|
||||||
|
import Control.Monad hiding (fmap)
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Void (Void)
|
||||||
|
import Plutus.Contract as Contract
|
||||||
|
import Plutus.Trace.Emulator as Emulator
|
||||||
|
import qualified PlutusTx
|
||||||
|
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||||
|
import Ledger hiding (mint, singleton)
|
||||||
|
import Ledger.Constraints as Constraints
|
||||||
|
import qualified Ledger.Typed.Scripts as Scripts
|
||||||
|
import Ledger.Value as Value
|
||||||
|
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||||
|
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||||
|
import Playground.Types (KnownCurrency (..))
|
||||||
|
import Prelude (IO, Semigroup (..), Show (..), String)
|
||||||
|
import Text.Printf (printf)
|
||||||
|
import Wallet.Emulator.Wallet
|
||||||
|
|
||||||
|
{-# INLINABLE tn #-}
|
||||||
|
tn :: TokenName
|
||||||
|
tn = TokenName emptyByteString
|
||||||
|
|
||||||
|
{-# INLINABLE mkPolicy #-}
|
||||||
|
mkPolicy :: TxOutRef -> () -> ScriptContext -> Bool
|
||||||
|
mkPolicy oref () ctx = traceIfFalse "UTxO not consumed" hasUTxO &&
|
||||||
|
traceIfFalse "wrong amount minted" checkMintedAmount
|
||||||
|
where
|
||||||
|
info :: TxInfo
|
||||||
|
info = scriptContextTxInfo ctx
|
||||||
|
|
||||||
|
hasUTxO :: Bool
|
||||||
|
hasUTxO = any (\i -> txInInfoOutRef i == oref) $ txInfoInputs info
|
||||||
|
|
||||||
|
checkMintedAmount :: Bool
|
||||||
|
checkMintedAmount = case flattenValue (txInfoForge info) of
|
||||||
|
[(cs, tn', amt)] -> cs == ownCurrencySymbol ctx && tn' == tn && amt == 1
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
policy :: TxOutRef -> Scripts.MintingPolicy
|
||||||
|
policy oref = mkMintingPolicyScript $
|
||||||
|
$$(PlutusTx.compile [|| Scripts.wrapMintingPolicy . mkPolicy ||])
|
||||||
|
`PlutusTx.applyCode`
|
||||||
|
PlutusTx.liftCode oref
|
||||||
|
|
||||||
|
curSymbol :: TxOutRef -> CurrencySymbol
|
||||||
|
curSymbol = scriptCurrencySymbol . policy
|
||||||
|
|
||||||
|
type NFTSchema = Endpoint "mint" ()
|
||||||
|
|
||||||
|
mint :: Contract w NFTSchema Text ()
|
||||||
|
mint = do
|
||||||
|
pk <- Contract.ownPubKey
|
||||||
|
utxos <- utxoAt (pubKeyAddress pk)
|
||||||
|
case Map.keys utxos of
|
||||||
|
[] -> Contract.logError @String "no utxo found"
|
||||||
|
oref : _ -> do
|
||||||
|
let val = Value.singleton (curSymbol oref) tn 1
|
||||||
|
lookups = Constraints.mintingPolicy (policy oref) <> Constraints.unspentOutputs utxos
|
||||||
|
tx = Constraints.mustMintValue val <> Constraints.mustSpendPubKeyOutput oref
|
||||||
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
||||||
|
void $ awaitTxConfirmed $ txId ledgerTx
|
||||||
|
Contract.logInfo @String $ printf "forged %s" (show val)
|
||||||
|
|
||||||
|
endpoints :: Contract () NFTSchema Text ()
|
||||||
|
endpoints = mint' >> endpoints
|
||||||
|
where
|
||||||
|
mint' = endpoint @"mint" >> mint
|
||||||
|
|
||||||
|
mkSchemaDefinitions ''NFTSchema
|
||||||
|
|
||||||
|
mkKnownCurrencies []
|
||||||
|
|
||||||
|
test :: IO ()
|
||||||
|
test = runEmulatorTraceIO $ do
|
||||||
|
h1 <- activateContractWallet (Wallet 1) endpoints
|
||||||
|
h2 <- activateContractWallet (Wallet 2) endpoints
|
||||||
|
callEndpoint @"mint" h1 ()
|
||||||
|
callEndpoint @"mint" h2 ()
|
||||||
|
void $ Emulator.waitNSlots 1
|
Loading…
Reference in a new issue