diff --git a/README.md b/README.md index dc3f3e1..263a7ce 100644 --- a/README.md +++ b/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. diff --git a/code/week03/plutus-pioneer-program-week03.cabal b/code/week03/plutus-pioneer-program-week03.cabal index be4547b..07639ed 100644 --- a/code/week03/plutus-pioneer-program-week03.cabal +++ b/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 diff --git a/code/week03/src/Week03/Vesting.hs b/code/week03/src/Week03/Vesting.hs new file mode 100644 index 0000000..77c6ba6 --- /dev/null +++ b/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 []