mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-21 22:32:00 +01:00
finished week 5
This commit is contained in:
parent
86c61c3592
commit
dfbfb3d733
5 changed files with 200 additions and 36 deletions
|
@ -11,6 +11,8 @@ License-files: LICENSE
|
|||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Week05.Free
|
||||
, Week05.Homework1
|
||||
, Week05.Homework2
|
||||
, Week05.NFT
|
||||
, Week05.Signed
|
||||
build-depends: aeson
|
||||
|
|
|
@ -12,24 +12,23 @@
|
|||
|
||||
module Week05.Free where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
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.Value as Value
|
||||
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||
import Playground.Types (KnownCurrency (..))
|
||||
import Text.Printf (printf)
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Ledger hiding (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 Text.Printf (printf)
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
{-# INLINABLE mkPolicy #-}
|
||||
|
|
98
code/week05/src/Week05/Homework1.hs
Normal file
98
code/week05/src/Week05/Homework1.hs
Normal file
|
@ -0,0 +1,98 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week05.Homework1 where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
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.Value as Value
|
||||
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||
import Playground.Types (KnownCurrency (..))
|
||||
import Prelude (Semigroup (..))
|
||||
import Text.Printf (printf)
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
{-# INLINABLE mkPolicy #-}
|
||||
-- This policy should only allow minting (or burning) of tokens if the owner of the specified PubKeyHash
|
||||
-- has signed the transaction and if the specified deadline has not passed.
|
||||
mkPolicy :: PubKeyHash -> Slot -> ScriptContext -> Bool
|
||||
mkPolicy pkh deadline ctx = True -- FIX ME!
|
||||
|
||||
policy :: PubKeyHash -> Slot -> Scripts.MonetaryPolicy
|
||||
policy pkh deadline = undefined -- IMPLEMENT ME!
|
||||
|
||||
curSymbol :: PubKeyHash -> Slot -> CurrencySymbol
|
||||
curSymbol pkh deadline = undefined -- IMPLEMENT ME!
|
||||
|
||||
data MintParams = MintParams
|
||||
{ mpTokenName :: !TokenName
|
||||
, mpDeadline :: !Slot
|
||||
, mpAmount :: !Integer
|
||||
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
||||
|
||||
type SignedSchema =
|
||||
BlockchainActions
|
||||
.\/ Endpoint "mint" MintParams
|
||||
|
||||
mint :: MintParams -> Contract w SignedSchema Text ()
|
||||
mint mp = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
now <- Contract.currentSlot
|
||||
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.monetaryPolicy $ policy pkh deadline
|
||||
tx = Constraints.mustForgeValue val <> Constraints.mustValidateIn (to deadline)
|
||||
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 = 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
|
68
code/week05/src/Week05/Homework2.hs
Normal file
68
code/week05/src/Week05/Homework2.hs
Normal file
|
@ -0,0 +1,68 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week05.Homework2 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 hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
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.Value as Value
|
||||
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||
import Playground.Types (KnownCurrency (..))
|
||||
import Prelude (Semigroup (..))
|
||||
import Text.Printf (printf)
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
{-# INLINABLE mkPolicy #-}
|
||||
-- Minting policy for an NFT, where the minting transaction must consume the given UTxO as input
|
||||
-- and where the TokenName will be the empty ByteString.
|
||||
mkPolicy :: TxOutRef -> ScriptContext -> Bool
|
||||
mkPolicy oref ctx = True -- FIX ME!
|
||||
|
||||
policy :: TxOutRef -> Scripts.MonetaryPolicy
|
||||
policy oref = undefined -- IMPLEMENT ME!
|
||||
|
||||
curSymbol :: TxOutRef -> CurrencySymbol
|
||||
curSymbol = undefined -- IMPLEMENT ME!
|
||||
|
||||
type NFTSchema =
|
||||
BlockchainActions
|
||||
.\/ Endpoint "mint" ()
|
||||
|
||||
mint :: Contract w NFTSchema Text ()
|
||||
mint = undefined -- IMPLEMENT ME!
|
||||
|
||||
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
|
|
@ -12,26 +12,23 @@
|
|||
|
||||
module Week05.NFT where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import Control.Monad hiding (fmap)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import Data.Void (Void)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
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.Value as Value
|
||||
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||
import Playground.Types (KnownCurrency (..))
|
||||
import Prelude (Semigroup (..))
|
||||
import Text.Printf (printf)
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Ledger hiding (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 (Semigroup (..))
|
||||
import Text.Printf (printf)
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
{-# INLINABLE mkPolicy #-}
|
||||
|
|
Loading…
Reference in a new issue