code for week 4

README.md

@@ -21,11 +21,18 @@
   - Time handling.
   - Parameterized contracts.
 
+- [Lecture #4](https://youtu.be/6Reuh0xZDjY)
+
+  - Monads
+  - The `EmulatorTrace` monad.
+  - The `Contract` monad.
+
 ## Code Examples
 
 - Lecture #1: [English Auction](code/week01)
 - Lecture #2: [Simple Validation](code/week02)
 - Lecture #3: [Validation Context & Parameterized Contracts](code/week03)
+- Lecture #4: [Monads, `EmulatorTrace` & `Contract`](code/week04)
 
 ## Exercises
 
@@ -53,6 +60,10 @@
   - Fix and complete the code in the [Homework1](code/week03/src/Week03/Homework1.hs) module.
   - Fix and complete the code in the [Homework2](code/week03/src/Week03/Homework2.hs) module.
 
+- Week #4
+
+  - Write an appropriate `EmulatorTrace` that uses the `payContract` contract in the [Homework](code/week04/src/Week04/Homework.hs) module.
+  - Catch errors in the `payContract` contract in the same module.
 
 ## Solutions
 
@@ -68,6 +79,7 @@
 
 ## Some Plutus Modules
 
+- [`Plutus.Trace.Emulator`](https://github.com/input-output-hk/plutus/blob/master/plutus-contract/src/Plutus/Trace/Emulator.hs), contains types and functions related to traces.
 - [`Plutus.V1.Ledger.Contexts`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Contexts.hs), contains the definition of the context-related types.
 - [`Plutus.V1.Ledger.Interval`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Interval.hs), contains the definition of and helper functions for the `Interval` type.
 - [`Plutus.V1.Ledger.Slot`](https://github.com/input-output-hk/plutus/blob/master/plutus-ledger-api/src/Plutus/V1/Ledger/Slot.hs), contains the definition of the `Slot` type.

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

@@ -10,10 +10,13 @@ License-files:       LICENSE
 
 library
   hs-source-dirs:      src
-  exposed-modules:     Week04.Either
+  exposed-modules:     Week04.Contract
+                     , Week04.Either
+                     , Week04.Homework
                      , Week04.Maybe
-                     , Week04.State
+                     , Week04.Monad
                      , Week04.Trace
+                     , Week04.Writer
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers

code/week04/src/Week04/Contract.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module Week04.Contract where
+
+import Control.Monad.Freer.Extras as Extras
+import Data.Functor               (void)
+import Data.Text                  (Text, unpack)
+import Data.Void                  (Void)
+import Plutus.Contract            as Contract
+import Plutus.Trace.Emulator      as Emulator
+import Wallet.Emulator.Wallet
+
+-- Contract w s e a
+-- EmulatorTrace a
+
+myContract1 :: Contract () BlockchainActions Text ()
+myContract1 = do
+    void $ Contract.throwError "BOOM!"
+    Contract.logInfo @String "Hello from the contract!"
+
+myTrace1 :: EmulatorTrace ()
+myTrace1 = void $ activateContractWallet (Wallet 1) myContract1
+
+test1 :: IO ()
+test1 = runEmulatorTraceIO myTrace1
+
+myContract2 :: Contract () BlockchainActions Void ()
+myContract2 = Contract.handleError
+    (\err -> Contract.logError $ "Caught error: " ++ unpack err)
+    myContract1
+
+myTrace2 :: EmulatorTrace ()
+myTrace2 = void $ activateContractWallet (Wallet 1) myContract2
+
+test2 :: IO ()
+test2 = runEmulatorTraceIO myTrace2
+
+type MySchema = BlockchainActions .\/ Endpoint "foo" Int
+
+myContract3 :: Contract () MySchema Text ()
+myContract3 = do
+    n <- endpoint @"foo"
+    Contract.logInfo n
+
+myTrace3 :: EmulatorTrace ()
+myTrace3 = do
+    h <- activateContractWallet (Wallet 1) myContract3
+    callEndpoint @"foo" h 42
+
+test3 :: IO ()
+test3 = runEmulatorTraceIO myTrace3
+
+myContract4 :: Contract [Int] BlockchainActions Text ()
+myContract4 = do
+    void $ Contract.waitNSlots 10
+    tell [1]
+    void $ Contract.waitNSlots 10
+    tell [2]
+    void $ Contract.waitNSlots 10
+
+myTrace4 :: EmulatorTrace ()
+myTrace4 = do
+    h <- activateContractWallet (Wallet 1) myContract4
+
+    void $ Emulator.waitNSlots 5
+    xs <- observableState h
+    Extras.logInfo $ show xs
+
+    void $ Emulator.waitNSlots 10
+    ys <- observableState h
+    Extras.logInfo $ show ys
+
+    void $ Emulator.waitNSlots 10
+    zs <- observableState h
+    Extras.logInfo $ show zs
+
+test4 :: IO ()
+test4 = runEmulatorTraceIO myTrace4

code/week04/src/Week04/Either.hs

@@ -1,6 +1,7 @@
 module Week04.Either where
 
 import Text.Read (readMaybe)
+import Week04.Monad
 
 readEither :: Read a => String -> Either String a
 readEither s = case readMaybe s of
@@ -25,3 +26,6 @@ foo' x y z = readEither x `bindEither` \k ->
              readEither y `bindEither` \l ->
              readEither z `bindEither` \m ->
              Right (k + l + m)
+
+foo'' :: String -> String -> String -> Either String Int
+foo'' x y z = threeInts (readEither x) (readEither y) (readEither z)

code/week04/src/Week04/Homework.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module Week04.Homework 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 = BlockchainActions .\/ Endpoint "pay" PayParams
+
+payContract :: Contract () PaySchema Text ()
+payContract = do
+    pp <- endpoint @"pay"
+    let tx = mustPayToPubKey (ppRecipient pp) $ lovelaceValueOf $ ppLovelace pp
+    void $ submitTx tx
+    payContract
+
+-- A trace that invokes the pay endpoint of payContract on Wallet 1 twice, each time with Wallet 2 as
+-- recipient, but with amounts given by the two arguments. There should be a delay of one slot
+-- after each endpoint call.
+payTrace :: Integer -> Integer -> EmulatorTrace ()
+payTrace x y = undefined -- IMPLEMENT ME!
+
+payTest1 :: IO ()
+payTest1 = runEmulatorTraceIO $ payTrace 1000000 2000000
+
+payTest2 :: IO ()
+payTest2 = runEmulatorTraceIO $ payTrace 1000000000 2000000

code/week04/src/Week04/Maybe.hs

@@ -1,6 +1,7 @@
 module Week04.Maybe where
 
 import Text.Read (readMaybe)
+import Week04.Monad
 
 foo :: String -> String -> String -> Maybe Int
 foo x y z = case readMaybe x of
@@ -20,3 +21,6 @@ foo' x y z = readMaybe x `bindMaybe` \k ->
              readMaybe y `bindMaybe` \l ->
              readMaybe z `bindMaybe` \m ->
              Just (k + l + m)
+
+foo'' :: String -> String -> String -> Maybe Int
+foo'' x y z = threeInts (readMaybe x) (readMaybe y) (readMaybe z)

code/week04/src/Week04/Monad.hs

@@ -0,0 +1,26 @@
+module Week04.Monad where
+
+-- (>>=)      :: IO a            -> (a -> IO b)            -> IO b
+-- bindMaybe  :: Maybe a         -> (a -> Maybe b)         -> Maybe b
+-- bindEither :: Either String a -> (a -> Either String b) -> Either String b
+-- bindWriter :: Writer a        -> (a -> Writer b)        -> Writer b
+--
+-- return              :: a -> IO a
+-- Just                :: a -> Maybe a
+-- Right               :: a -> Either String a
+-- (\a -> Writer a []) :: a -> Writer a
+
+threeInts :: Monad m => m Int -> m Int -> m Int -> m Int
+threeInts mx my mz =
+    mx >>= \k ->
+    my >>= \l ->
+    mz >>= \m ->
+    let s = k + l + m in return s
+
+threeInts' :: Monad m => m Int -> m Int -> m Int -> m Int
+threeInts' mx my mz = do
+    k <- mx
+    l <- my
+    m <- mz
+    let s = k + l + m
+    return s

code/week04/src/Week04/State.hs

@@ -1,2 +0,0 @@
-module Week04.State where
-

code/week04/src/Week04/Trace.hs

@@ -1,26 +1,32 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds        #-}
+
 module Week04.Trace where
 
 import Control.Monad.Freer.Extras as Extras
 import Data.Functor               (void)
-import Data.Text                  (Text)
+import Ledger
-import Plutus.Contract            as Contract
 import Plutus.Trace.Emulator      as Emulator
 import Wallet.Emulator.Wallet
 
+import Week04.Vesting
+
+-- Contract w s e a
+-- EmulatorTrace a
+
 test :: IO ()
 test = runEmulatorTraceIO myTrace
 
 myTrace :: EmulatorTrace ()
 myTrace = do
-    h  <- activateContractWallet (Wallet 1) myContract
+    h1 <- activateContractWallet (Wallet 1) endpoints
-    void $ Emulator.waitNSlots 1
+    h2 <- activateContractWallet (Wallet 2) endpoints
-    xs <- Emulator.observableState h
+    callEndpoint @"give" h1 $ GiveParams
-    Extras.logInfo $ show xs
+        { gpBeneficiary = pubKeyHash $ walletPubKey $ Wallet 2
-
+        , gpDeadline    = Slot 20
-
+        , gpAmount      = 1000
-myContract :: Contract [Int] BlockchainActions Text ()
+        }
-myContract = do
+    void $ waitUntilSlot 20
-    Contract.logInfo "logging..."
+    callEndpoint @"grab" h2 ()
-    tell [1]
+    s <- waitNSlots 1
-    void $ Contract.waitNSlots 10
+    Extras.logInfo $ "reached slot " ++ show s
-    myContract

code/week04/src/Week04/Vesting.hs

@@ -0,0 +1,132 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week04.Vesting
+    ( GiveParams (..)
+    , VestingSchema
+    , endpoints
+    ) 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  (ToSchema)
+import           Prelude              (Semigroup (..))
+import           Text.Printf          (printf)
+
+data VestingDatum = VestingDatum
+    { beneficiary :: PubKeyHash
+    , deadline    :: Slot
+    } deriving Show
+
+PlutusTx.unstableMakeIsData ''VestingDatum
+
+{-# INLINABLE mkValidator #-}
+mkValidator :: VestingDatum -> () -> ScriptContext -> Bool
+mkValidator dat () ctx =
+    traceIfFalse "beneficiary's signature missing" checkSig      &&
+    traceIfFalse "deadline not reached"            checkDeadline
+  where
+    info :: TxInfo
+    info = scriptContextTxInfo ctx
+
+    checkSig :: Bool
+    checkSig = beneficiary dat `elem` txInfoSignatories info
+
+    checkDeadline :: Bool
+    checkDeadline = from (deadline dat) `contains` txInfoValidRange info
+
+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
+    let dat = VestingDatum
+                { beneficiary = gpBeneficiary gp
+                , 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 <- Map.filter (isSuitable pkh now) <$> utxoAt scrAddress
+    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
+                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 :: PubKeyHash -> Slot -> TxOutTx -> Bool
+    isSuitable pkh 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  -> beneficiary d == pkh && deadline d <= now
+
+endpoints :: Contract () VestingSchema Text ()
+endpoints = (give' `select` grab') >> endpoints
+  where
+    give' = endpoint @"give" >>= give
+    grab' = endpoint @"grab" >>  grab

code/week04/src/Week04/Writer.hs

@@ -0,0 +1,53 @@
+module Week04.Writer where
+
+import Control.Monad
+import Week04.Monad
+
+data Writer a = Writer a [String]
+    deriving Show
+
+number :: Int -> Writer Int
+number n = Writer n $ ["number: " ++ show n]
+
+tell :: [String] -> Writer ()
+tell = Writer ()
+
+foo :: Writer Int -> Writer Int -> Writer Int -> Writer Int
+foo (Writer k xs) (Writer l ys) (Writer m zs) =
+  let
+    s = k + l + m
+    Writer _ us = tell ["sum: " ++ show s]
+  in
+    Writer s $ xs ++ ys ++ zs ++ us
+
+bindWriter :: Writer a -> (a -> Writer b) -> Writer b
+bindWriter (Writer a xs) f =
+  let
+    Writer b ys = f a
+  in
+    Writer b $ xs ++ ys
+
+foo' :: Writer Int -> Writer Int -> Writer Int -> Writer Int
+foo' x y z = x `bindWriter` \k ->
+             y `bindWriter` \l ->
+             z `bindWriter` \m ->
+             let s = k + l + m
+             in tell ["sum: " ++ show s] `bindWriter` \_ ->
+                Writer s []
+
+foo'' :: Writer Int -> Writer Int -> Writer Int -> Writer Int
+foo'' x y z = do
+    s <- threeInts x y z
+    tell ["sum: " ++ show s]
+    return s
+
+instance Functor Writer where
+    fmap = liftM
+
+instance Applicative Writer where
+    pure = return
+    (<*>) = ap
+
+instance Monad Writer where
+    return a = Writer a []
+    (>>=) = bindWriter