week 3

README.md

@@ -15,10 +15,17 @@
   - Low-level, untyped on-chain validation scripts.
   - High-level, typed on-chain validation scripts.
 
+- [Lecture #3](https://youtu.be/Lk1eIVm_ZTQ)
+
+  - Script context.
+  - Time handling.
+  - Parameterized contracts.
+
 ## Code Examples
 
 - Lecture #1: [English Auction](code/week01)
 - Lecture #2: [Simple Validation](code/week02)
+- Lecture #3: [Validation Context & Parameterized Contracts](code/week03)
 
 ## Exercises
 
@@ -41,6 +48,12 @@
   - Fix and complete the code in the [Homework1](code/week02/src/Week02/Homework1.hs) module.
   - Fix and complete the code in the [Homework2](code/week02/src/Week02/Homework2.hs) module.
 
+- Week #3
+
+  - Fix and complete the code in the [Homework1](code/week03/src/Week02/Homework1.hs) module.
+  - Fix and complete the code in the [Homework2](code/week03/src/Week02/Homework2.hs) module.
+
+
 ## Solutions
 
 - Week #2

code/week03/plutus-pioneer-program-week03.cabal

@@ -11,6 +11,8 @@ License-files:       LICENSE
 library
   hs-source-dirs:      src
   exposed-modules:     Week03.IsData
+                     , Week03.Homework1
+                     , Week03.Homework2
                      , Week03.Parameterized
                      , Week03.Vesting
   build-depends:       aeson

code/week03/src/Week03/Homework1.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week03.Homework1 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      hiding (when)
+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 qualified Prelude              as P
+import           Text.Printf          (printf)
+
+data VestingDatum = VestingDatum
+    { beneficiary1 :: PubKeyHash
+    , beneficiary2 :: PubKeyHash
+    , deadline     :: Slot
+    } deriving Show
+
+PlutusTx.unstableMakeIsData ''VestingDatum
+
+{-# INLINABLE mkValidator #-}
+-- This should validate if either beneficiary1 has signed the transaction and the current slot is before or at the deadline
+-- or if beneficiary2 has signed the transaction and the deadline has passed.
+mkValidator :: VestingDatum -> () -> ScriptContext -> Bool
+mkValidator _ _ _ = False -- FIX ME!
+
+data Vesting
+instance Scripts.ScriptType Vesting where
+    type instance DatumType Vesting = VestingDatum
+    type instance RedeemerType Vesting = ()
+
+inst :: Scripts.ScriptInstance Vesting
+inst = Scripts.validator @Vesting
+    $$(PlutusTx.compile [|| mkValidator ||])
+    $$(PlutusTx.compile [|| wrap ||])
+  where
+    wrap = Scripts.wrapValidator @VestingDatum @()
+
+validator :: Validator
+validator = Scripts.validatorScript inst
+
+scrAddress :: Ledger.Address
+scrAddress = scriptAddress validator
+
+data GiveParams = GiveParams
+    { gpBeneficiary :: !PubKeyHash
+    , gpDeadline    :: !Slot
+    , gpAmount      :: !Integer
+    } deriving (Generic, ToJSON, FromJSON, ToSchema)
+
+type VestingSchema =
+    BlockchainActions
+        .\/ Endpoint "give" GiveParams
+        .\/ Endpoint "grab" ()
+
+give :: (HasBlockchainActions s, 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 inst 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. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
+grab = do
+    now    <- currentSlot
+    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/Homework2.hs

@@ -0,0 +1,111 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude     #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module Week03.Homework2 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      hiding (when)
+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              (Semigroup (..))
+import           Text.Printf          (printf)
+
+{-# INLINABLE mkValidator #-}
+mkValidator :: PubKeyHash -> Slot -> () -> ScriptContext -> Bool
+mkValidator _ _ _ _ = False -- FIX ME!
+
+data Vesting
+instance Scripts.ScriptType Vesting where
+    type instance DatumType Vesting = Slot
+    type instance RedeemerType Vesting = ()
+
+inst :: PubKeyHash -> Scripts.ScriptInstance Vesting
+inst = undefined -- IMPLEMENT ME!
+
+validator :: PubKeyHash -> Validator
+validator = undefined -- IMPLEMENT ME!
+
+scrAddress :: PubKeyHash -> Ledger.Address
+scrAddress = undefined -- IMPLEMENT ME!
+
+data GiveParams = GiveParams
+    { gpBeneficiary :: !PubKeyHash
+    , gpDeadline    :: !Slot
+    , gpAmount      :: !Integer
+    } deriving (Generic, ToJSON, FromJSON, ToSchema)
+
+type VestingSchema =
+    BlockchainActions
+        .\/ Endpoint "give" GiveParams
+        .\/ Endpoint "grab" ()
+
+give :: (HasBlockchainActions s, 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 (inst 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. (HasBlockchainActions s, AsContractError e) => Contract w s e ()
+grab = do
+    now   <- currentSlot
+    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 :: Slot -> 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/week03/src/Week03/Parameterized.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude     #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
@@ -10,18 +11,7 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 
-module Week03.Parameterized
+module Week03.Parameterized where
-    ( give
-    , grab
-    , ParameterizedSchema
-    , endpoints
-    , schemas
-    , registeredKnownCurrencies
-    , printJson
-    , printSchemas
-    , ensureKnownCurrencies
-    , stage
-    ) where
 
 import           Control.Monad        hiding (fmap)
 import           Data.Aeson           (ToJSON, FromJSON)
@@ -30,86 +20,115 @@ import           Data.Text            (Text)
 import           Data.Void            (Void)
 import           GHC.Generics         (Generic)
 import           Plutus.Contract      hiding (when)
-import           PlutusTx             (Data (..))
 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)
+import           Playground.Contract  (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
 import           Playground.TH        (mkKnownCurrencies, mkSchemaDefinitions)
 import           Playground.Types     (KnownCurrency (..))
 import           Prelude              (Semigroup (..))
-import           Schema               (ToSchema)
 import           Text.Printf          (printf)
 
-{-# INLINABLE mkParameterizedValidator #-}
+data VestingParam = VestingParam
-mkParameterizedValidator :: Integer -> () -> Integer -> ScriptContext -> Bool
+    { beneficiary :: PubKeyHash
-mkParameterizedValidator r () n _ = traceIfFalse "UNEXPECTED REDEEMER" (n == r)
+    , deadline    :: Slot
+    } deriving Show
 
-data Parameterizing
+PlutusTx.unstableMakeIsData ''VestingParam
-instance Scripts.ScriptType Parameterizing where
+PlutusTx.makeLift ''VestingParam
-    type instance RedeemerType Parameterizing = Integer
-    type instance DatumType Parameterizing = ()
 
-parameterizedInstance :: Integer -> Scripts.ScriptInstance Parameterizing
+{-# INLINABLE mkValidator #-}
-parameterizedInstance r = Scripts.validator @Parameterizing
+mkValidator :: VestingParam -> () -> () -> ScriptContext -> Bool
-    ($$(PlutusTx.compile [|| mkParameterizedValidator ||])
+mkValidator p () () ctx =
-        `PlutusTx.applyCode`
+    traceIfFalse "beneficiary's signature missing" checkSig      &&
-            PlutusTx.liftCode r)
+    traceIfFalse "deadline not reached"            checkDeadline
+  where
+    info :: TxInfo
+    info = scriptContextTxInfo ctx
+
+    checkSig :: Bool
+    checkSig = beneficiary p `elem` txInfoSignatories info
+
+    checkDeadline :: Bool
+    checkDeadline = from (deadline p) `contains` txInfoValidRange info
+
+data Vesting
+instance Scripts.ScriptType Vesting where
+    type instance DatumType Vesting = ()
+    type instance RedeemerType Vesting = ()
+
+inst :: VestingParam -> Scripts.ScriptInstance Vesting
+inst p = Scripts.validator @Vesting
+    ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode p)
     $$(PlutusTx.compile [|| wrap ||])
   where
-    wrap = Scripts.wrapValidator @() @Integer
+    wrap = Scripts.wrapValidator @() @()
 
-parameterizedValidator :: Integer -> Validator
+validator :: VestingParam -> Validator
-parameterizedValidator = Scripts.validatorScript . parameterizedInstance
+validator = Scripts.validatorScript . inst
 
-parameterizedAddress :: Integer -> Ledger.Address
+scrAddress :: VestingParam -> Ledger.Address
-parameterizedAddress = scriptAddress . parameterizedValidator
+scrAddress = scriptAddress . validator
-
-type ParameterizedSchema =
-    BlockchainActions
-        .\/ Endpoint "give" GiveParams
-        .\/ Endpoint "grab" GrabParams
 
 data GiveParams = GiveParams
-    { giveAmount    :: Integer
+    { gpBeneficiary :: !PubKeyHash
-    , giveParameter :: Integer
+    , gpDeadline    :: !Slot
+    , gpAmount      :: !Integer
     } deriving (Generic, ToJSON, FromJSON, ToSchema)
 
-data GrabParams = GrabParams
+type VestingSchema =
-    { grabParameter :: Integer
+    BlockchainActions
-    , grabRedeemer  :: Integer
+        .\/ Endpoint "give" GiveParams
-    } deriving (Generic, ToJSON, FromJSON, ToSchema)
+        .\/ Endpoint "grab" Slot
 
 give :: (HasBlockchainActions s, AsContractError e) => GiveParams -> Contract w s e ()
-give p = do
+give gp = do
-    let amount = giveAmount p
+    let p  = VestingParam
-    let tx     = mustPayToTheScript () $ Ada.lovelaceValueOf amount
+                { beneficiary = gpBeneficiary gp
-    ledgerTx <- submitTxConstraints (parameterizedInstance $ giveParameter p) tx
+                , deadline    = gpDeadline gp
+                }
+        tx = mustPayToTheScript () $ Ada.lovelaceValueOf $ gpAmount gp
+    ledgerTx <- submitTxConstraints (inst p) tx
     void $ awaitTxConfirmed $ txId ledgerTx
-    logInfo @String $ printf "made a gift of %d lovelace" amount
+    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. (HasBlockchainActions s, AsContractError e) => GrabParams -> Contract w s e ()
+grab :: forall w s e. (HasBlockchainActions s, AsContractError e) => Slot -> Contract w s e ()
-grab p = do
+grab d = do
-    let par = grabParameter p
+    now   <- currentSlot
-    utxos <- utxoAt $ parameterizedAddress par
+    pkh   <- pubKeyHash <$> ownPubKey
+    if now < d
+        then logInfo @String $ "too early"
+        else do
+            let p = VestingParam
+                        { beneficiary = pkh
+                        , deadline    = d
+                        }
+            utxos <- utxoAt $ scrAddress p
+            if Map.null utxos
+                then logInfo @String $ "no gifts available"
+                else do
                     let orefs   = fst <$> Map.toList utxos
                         lookups = Constraints.unspentOutputs utxos      <>
-                  Constraints.otherScript (parameterizedValidator par)
+                                  Constraints.otherScript (validator p)
                         tx :: TxConstraints Void Void
-        tx      = mconcat [mustSpendScriptOutput oref $ Redeemer $ I $ grabRedeemer p | oref <- orefs]
+                        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"
 
-endpoints :: Contract () ParameterizedSchema Text ()
+endpoints :: Contract () VestingSchema Text ()
 endpoints = (give' `select` grab') >> endpoints
   where
     give' = endpoint @"give" >>= give
     grab' = endpoint @"grab" >>= grab
 
-mkSchemaDefinitions ''ParameterizedSchema
+mkSchemaDefinitions ''VestingSchema
 
 mkKnownCurrencies []