Skip to content

Commit

Permalink
fixed homework and solutions
Browse files Browse the repository at this point in the history
  • Loading branch information
@brunjlar
brunjlar committed Jan 26, 2022
1 parent fdc6e03 commit edd0587
Show file tree
Hide file tree
Showing 5 changed files with 276 additions and 5 deletions.
2 changes: 2 additions & 0 deletions code/week03/plutus-pioneer-program-week03.cabal
View file
Expand Up @@ -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
Expand Down
3 changes: 0 additions & 3 deletions code/week03/src/Week03/Homework1.hs
View file
Expand Up @@ -64,9 +64,6 @@ typedValidator = Scripts.mkTypedValidator @Vesting
validator :: Validator
validator = Scripts.validatorScript typedValidator

valHash :: Ledger.ValidatorHash
valHash = Scripts.validatorHash typedValidator

scrAddress :: Ledger.Address
scrAddress = scriptAddress validator

Expand Down
4 changes: 2 additions & 2 deletions code/week03/src/Week03/Homework2.hs
View file
Expand Up @@ -36,7 +36,7 @@ import Text.Printf (printf)
{-# OPTIONS_GHC -fno-warn-unused-imports #-}

{-# INLINABLE mkValidator #-}
mkValidator :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
mkValidator :: PaymentPubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
mkValidator _ _ _ _ = False -- FIX ME!

data Vesting
Expand Down Expand Up @@ -96,7 +96,7 @@ grab = do
isSuitable :: POSIXTime -> ChainIndexTxOut -> Bool
isSuitable now o = case _ciTxOutDatum o of
Left _ -> False
Right (Datum d) -> case PlutusTx.fromBuiltinData d of
Right (Datum e) -> case PlutusTx.fromBuiltinData e of
Nothing -> False
Just d -> d <= now

Expand Down
146 changes: 146 additions & 0 deletions code/week03/src/Week03/Solution1.hs
View file
@@ -0,0 +1,146 @@
{-# 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 (TxConstraints)
import qualified 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)
import qualified Prelude as P
import Text.Printf (printf)

data VestingDatum = VestingDatum
{ beneficiary1 :: PaymentPubKeyHash
, beneficiary2 :: PaymentPubKeyHash
, deadline :: POSIXTime
} deriving P.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 dat () ctx
| (unPaymentPubKeyHash (beneficiary1 dat) `elem` sigs) && (to (deadline dat) `contains` range) = True
| (unPaymentPubKeyHash (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 :: !PaymentPubKeyHash
, 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 <- ownPaymentPubKeyHash
let dat = VestingDatum
{ beneficiary1 = gpBeneficiary gp
, beneficiary2 = pkh
, deadline = gpDeadline gp
}
tx = Constraints.mustPayToTheScript dat $ Ada.lovelaceValueOf $ gpAmount gp
ledgerTx <- submitTxConstraints typedValidator tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @P.String $ printf "made a gift of %d lovelace to %s with deadline %s"
(gpAmount gp)
(P.show $ gpBeneficiary gp)
(P.show $ gpDeadline gp)

grab :: forall w s e. AsContractError e => Contract w s e ()
grab = do
now <- currentTime
pkh <- ownPaymentPubKeyHash
utxos <- utxosAt 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 @P.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 [Constraints.mustSpendScriptOutput oref unitRedeemer | oref <- orefs] P.<>
Constraints.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 [Constraints.mustSpendScriptOutput oref $ unitRedeemer | oref <- orefs] P.<>
Constraints.mustValidateIn (from now)
void $ submitTxConstraintsWith @Void lookups tx
where
isSuitable :: (VestingDatum -> Bool) -> ChainIndexTxOut -> Bool
isSuitable p o = case _ciTxOutDatum o of
Left _ -> False
Right (Datum d) -> maybe False p $ PlutusTx.fromBuiltinData d

endpoints :: Contract () VestingSchema Text ()
endpoints = awaitPromise (give' `select` grab') >> endpoints
where
give' = endpoint @"give" give
grab' = endpoint @"grab" $ const grab

mkSchemaDefinitions ''VestingSchema

mkKnownCurrencies []
126 changes: 126 additions & 0 deletions code/week03/src/Week03/Solution2.hs
View file
@@ -0,0 +1,126 @@
{-# 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.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 (TxConstraints)
import qualified 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, undefined)
import Text.Printf (printf)

{-# OPTIONS_GHC -fno-warn-unused-imports #-}

{-# INLINABLE mkValidator #-}
mkValidator :: PaymentPubKeyHash -> 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 = unPaymentPubKeyHash 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 :: PaymentPubKeyHash -> 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 :: PaymentPubKeyHash -> Validator
validator = Scripts.validatorScript . typedValidator

scrAddress :: PaymentPubKeyHash -> Ledger.Address
scrAddress = scriptAddress . validator

data GiveParams = GiveParams
{ gpBeneficiary :: !PaymentPubKeyHash
, 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 = Constraints.mustPayToTheScript d $ Ada.lovelaceValueOf $ gpAmount gp
ledgerTx <- submitTxConstraints (typedValidator p) tx
void $ awaitTxConfirmed $ getCardanoTxId 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 <- ownPaymentPubKeyHash
utxos <- Map.filter (isSuitable now) <$> utxosAt (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 [Constraints.mustSpendScriptOutput oref unitRedeemer | oref <- orefs] <>
Constraints.mustValidateIn (from now)
ledgerTx <- submitTxConstraintsWith @Void lookups tx
void $ awaitTxConfirmed $ getCardanoTxId ledgerTx
logInfo @String $ "collected gifts"
where
isSuitable :: POSIXTime -> ChainIndexTxOut -> Bool
isSuitable now o = case _ciTxOutDatum o of
Left _ -> False
Right (Datum e) -> case PlutusTx.fromBuiltinData e of
Nothing -> False
Just d -> d <= now

endpoints :: Contract () VestingSchema Text ()
endpoints = awaitPromise (give' `select` grab') >> endpoints
where
give' = endpoint @"give" give
grab' = endpoint @"grab" $ const grab

mkSchemaDefinitions ''VestingSchema

mkKnownCurrencies []

0 comments on commit edd0587

Please sign in to comment.