added old solutions

This commit is contained in:
Lars Brünjes 2021-07-28 23:22:05 +02:00
parent 1d223b2206
commit b9736840bb
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
11 changed files with 722 additions and 0 deletions

View file

@ -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

View 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 []

View 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 []

View file

@ -13,6 +13,8 @@ library
exposed-modules: Week03.Homework1
, Week03.Homework2
, Week03.Parameterized
, Week03.Solution1
, Week03.Solution2
, Week03.Vesting
build-depends: aeson
, base ^>=4.14.1.0

View 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 []

View 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 []

View file

@ -15,6 +15,7 @@ library
, Week04.Homework
, Week04.Maybe
, Week04.Monad
, Week04.Solution
, Week04.Trace
, Week04.Writer
other-modules: Week04.Vesting

View 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

View file

@ -15,6 +15,8 @@ library
, Week05.Homework2
, Week05.NFT
, Week05.Signed
, Week05.Solution1
, Week05.Solution2
build-depends: aeson
, base ^>=4.14.1.0
, containers

View 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

View 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