continued with week 3

README.md

@@ -50,6 +50,9 @@
 
 ## Some Plutus Modules
 
+- [`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.
 - [`PlutusTx.Data`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/Data.hs), contains the definition of the `Data` type.
 - [`PlutusTx.IsData.Class`](https://github.com/input-output-hk/plutus/blob/master/plutus-tx/src/PlutusTx/IsData/Class.hs), defines the `IsData` class.
 

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

@@ -12,12 +12,14 @@ library
   hs-source-dirs:      src
   exposed-modules:     Week03.IsData
                      , Week03.Parameterized
+                     , Week03.Vesting
   build-depends:       aeson
                      , base ^>=4.14.1.0
                      , containers
                      , playground-common
                      , plutus-contract
                      , plutus-ledger
+                     , plutus-ledger-api
                      , plutus-tx-plugin
                      , plutus-tx
                      , text

code/week03/src/Week03/Vesting.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveAnyClass      #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE NoImplicitPrelude   #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Week03.Vesting 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)
+
+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
+
+mkSchemaDefinitions ''VestingSchema
+
+mkKnownCurrencies []