added old solutions

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

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

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

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

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

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

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

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

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

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

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