diff --git a/code/week02/plutus-pioneer-program-week02.cabal b/code/week02/plutus-pioneer-program-week02.cabal index d88f361..d60115b 100644 --- a/code/week02/plutus-pioneer-program-week02.cabal +++ b/code/week02/plutus-pioneer-program-week02.cabal @@ -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 diff --git a/code/week02/src/Week02/Solution1.hs b/code/week02/src/Week02/Solution1.hs new file mode 100644 index 0000000..06be1c1 --- /dev/null +++ b/code/week02/src/Week02/Solution1.hs @@ -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 [] diff --git a/code/week02/src/Week02/Solution2.hs b/code/week02/src/Week02/Solution2.hs new file mode 100644 index 0000000..f9d1762 --- /dev/null +++ b/code/week02/src/Week02/Solution2.hs @@ -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 [] diff --git a/code/week03/plutus-pioneer-program-week03.cabal b/code/week03/plutus-pioneer-program-week03.cabal index b329349..91502dd 100644 --- a/code/week03/plutus-pioneer-program-week03.cabal +++ b/code/week03/plutus-pioneer-program-week03.cabal @@ -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 diff --git a/code/week03/src/Week03/Solution1.hs b/code/week03/src/Week03/Solution1.hs new file mode 100644 index 0000000..d9fe216 --- /dev/null +++ b/code/week03/src/Week03/Solution1.hs @@ -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 [] diff --git a/code/week03/src/Week03/Solution2.hs b/code/week03/src/Week03/Solution2.hs new file mode 100644 index 0000000..041f123 --- /dev/null +++ b/code/week03/src/Week03/Solution2.hs @@ -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 [] diff --git a/code/week04/plutus-pioneer-program-week04.cabal b/code/week04/plutus-pioneer-program-week04.cabal index d3deb2a..d684ebb 100644 --- a/code/week04/plutus-pioneer-program-week04.cabal +++ b/code/week04/plutus-pioneer-program-week04.cabal @@ -15,6 +15,7 @@ library , Week04.Homework , Week04.Maybe , Week04.Monad + , Week04.Solution , Week04.Trace , Week04.Writer other-modules: Week04.Vesting diff --git a/code/week04/src/Week04/Solution.hs b/code/week04/src/Week04/Solution.hs new file mode 100644 index 0000000..7ba6f0d --- /dev/null +++ b/code/week04/src/Week04/Solution.hs @@ -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 diff --git a/code/week05/plutus-pioneer-program-week05.cabal b/code/week05/plutus-pioneer-program-week05.cabal index db80e22..2857bee 100644 --- a/code/week05/plutus-pioneer-program-week05.cabal +++ b/code/week05/plutus-pioneer-program-week05.cabal @@ -15,6 +15,8 @@ library , Week05.Homework2 , Week05.NFT , Week05.Signed + , Week05.Solution1 + , Week05.Solution2 build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week05/src/Week05/Solution1.hs b/code/week05/src/Week05/Solution1.hs new file mode 100644 index 0000000..9fc6cf3 --- /dev/null +++ b/code/week05/src/Week05/Solution1.hs @@ -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 diff --git a/code/week05/src/Week05/Solution2.hs b/code/week05/src/Week05/Solution2.hs new file mode 100644 index 0000000..5610d70 --- /dev/null +++ b/code/week05/src/Week05/Solution2.hs @@ -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