127 lines
4.8 KiB
Haskell
127 lines
4.8 KiB
Haskell
{-# 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
|
|
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 (IO, Semigroup (..), Show (..), String, undefined)
|
|
import Text.Printf (printf)
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
|
|
|
{-# INLINABLE mkValidator #-}
|
|
mkValidator :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
|
|
mkValidator pkey dline () ctx = traceIfFalse "beneficiary signature missing" signedByBeneficiary &&
|
|
traceIfFalse "deadline not reached" deadlineReached
|
|
where
|
|
info :: TxInfo
|
|
info = scriptContextTxInfo ctx
|
|
|
|
signedByBeneficiary :: Bool
|
|
signedByBeneficiary = txSignedBy info $ pkey
|
|
|
|
deadlineReached :: Bool
|
|
deadlineReached = contains (from $ dline) $ txInfoValidRange info
|
|
|
|
data Vesting
|
|
instance Scripts.ValidatorTypes Vesting where
|
|
type instance DatumType Vesting = POSIXTime
|
|
type instance RedeemerType Vesting = ()
|
|
|
|
typedValidator :: PubKeyHash -> 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 :: PubKeyHash -> Validator
|
|
validator = Scripts.validatorScript . typedValidator
|
|
|
|
scrAddress :: PubKeyHash -> Ledger.Address
|
|
scrAddress = scriptAddress . validator
|
|
|
|
data GiveParams = GiveParams
|
|
{ gpBeneficiary :: !PubKeyHash
|
|
, 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 = mustPayToTheScript d $ Ada.lovelaceValueOf $ gpAmount gp
|
|
ledgerTx <- submitTxConstraints (typedValidator 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. AsContractError e => Contract w s e ()
|
|
grab = do
|
|
now <- currentTime
|
|
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 :: POSIXTime -> 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 []
|