Plutus Playground Smart Contract

Playground.hs

-- | Vesting scheme as a PLC contract
module Vesting where

import           Control.Monad                (void)

import qualified Language.PlutusTx            as PlutusTx
import qualified Ledger.Interval              as Interval
import qualified Language.PlutusTx.Prelude    as P
import           Ledger
import           Ledger.Ada                   (Ada)
import qualified Ledger.Ada.TH                as Ada
import           Ledger.Validation
import           Wallet
import           Playground.Contract

-- | Tranche of a vesting scheme.
data VestingTranche = VestingTranche {
    vestingTrancheDate   :: Slot,
    vestingTrancheAmount :: Ada
    } deriving (Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeLift ''VestingTranche

-- | A vesting scheme consisting of two tranches. Each tranche defines a date
--   (slot) after which an additional amount of money can be spent.
data Vesting = Vesting {
    vestingTranche1 :: VestingTranche,
    vestingTranche2 :: VestingTranche,
    vestingOwner    :: PubKey
    } deriving (Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeLift ''Vesting

-- | The total amount of money vested
totalAmount :: Vesting -> Ada
totalAmount Vesting{..} =
    vestingTrancheAmount vestingTranche1 + vestingTrancheAmount vestingTranche2

-- | Data script for vesting utxo
data VestingData = VestingData {
    vestingDataHash    :: ValidatorHash, -- ^ Hash of the validator script
    vestingDataPaidOut :: Ada -- ^ How much of the vested value has already been retrieved
    } deriving (Eq, Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeLift ''VestingData

-- | Lock some funds with the vesting validator script and return a
--   [[VestingData]] representing the current state of the process
vestFunds :: MonadWallet m => Vesting -> Ada -> m ()
vestFunds vst adaAmount = do
    _ <- if adaAmount < totalAmount vst then throwOtherError "Value must not be smaller than vested amount" else pure ()
    let value = $$(Ada.toValue) adaAmount
    (payment, change) <- createPaymentWithChange value
    let contractAddress = Ledger.scriptAddress (validatorScript vst)
        dataScript      = DataScript (Ledger.lifted vd)
        vd =  VestingData (validatorScriptHash vst) 0
    payToScript_ defaultSlotRange contractAddress value dataScript

-- | Register this wallet as the owner of the vesting scheme. At each of the
--   two dates (tranche 1, tranche 2) we take out the funds that have been
--   released so far.
--   This function has to be called before the funds are vested, so that the
--   wallet can start watching the contract address for changes.
registerVestingOwner :: MonadWallet m => Vesting -> m ()
registerVestingOwner v = do
    ourPubKey <- ownPubKey
    let
        o = vestingOwner v
        addr = Ledger.scriptAddress (validatorScript v)
    _ <- if o /= ourPubKey
         then throwOtherError "Vesting scheme is not owned by this wallet"
         else startWatching addr

    register (tranche2Trigger v) (tranche2Handler v)
    -- ^ This runs `tranche2Handler` as soon as the final funds are released.
    --   It is possible to take out funds from tranche 1 earlier than that
    --   (as explained in the script code, below) but doing so requires some
    --   low-level code dealing with the transaction outputs, because we don't
    --   have a nice interface for this in 'Wallet.API' yet.


validatorScriptHash :: Vesting -> ValidatorHash
validatorScriptHash =
    plcValidatorDigest
    . Ledger.getAddress
    . Ledger.scriptAddress
    . validatorScript

validatorScript :: Vesting -> ValidatorScript
validatorScript v = ValidatorScript val where
    val = Ledger.applyScript inner (Ledger.lifted v)
    inner = $$(Ledger.compileScript [|| \Vesting{..} () VestingData{..} (p :: PendingTx) ->
        let

            eqPk :: PubKey -> PubKey -> Bool
            eqPk = $$(eqPubKey)

            infixr 3 &&
            (&&) :: Bool -> Bool -> Bool
            (&&) = $$(P.and)

            PendingTx _ os _ _ _ range = p
            VestingTranche d1 a1 = vestingTranche1
            VestingTranche d2 a2 = vestingTranche2

            -- We assume here that the txn outputs are always given in the same
            -- order (1 PubKey output, followed by 0 or 1 script outputs)
            amountSpent :: Ada
            amountSpent = case os of
                PendingTxOut v' _ (PubKeyTxOut pk):_
                    | pk `eqPk` vestingOwner -> $$(Ada.fromValue) v'
                _ -> $$(P.error) ()

            -- Value that has been released so far under the scheme
            currentThreshold =
                if $$(Interval.contains) ($$(Interval.from) d1) range
                then if $$(Interval.contains) ($$(Interval.from) d2) range
                    -- everything can be spent
                        then $$(Ada.plus) a1 a2
                        -- only the first tranche can be spent (we are between d1 and d2)
                        else a1
                -- Nothing has been released yet
                else $$(Ada.zero)


            paidOut = vestingDataPaidOut
            newAmount = $$(Ada.plus) paidOut amountSpent

            -- Verify that the amount taken out, plus the amount already taken
            -- out before, does not exceed the threshold that is currently
            -- allowed
            amountsValid = $$(Ada.leq) newAmount currentThreshold

            -- Check that the remaining output is locked by the same validation
            -- script
            txnOutputsValid = case os of
                _:PendingTxOut _ (Just (vl', _)) DataTxOut:_ -> $$(eqValidator) vl' vestingDataHash
                -- If there is no data script in the output list,
                -- we only accept the transaction if we are past the
                -- date of the final tranche.
                _ -> $$(Interval.before) d2 range

            isValid = amountsValid && txnOutputsValid
        in
        if isValid then () else $$(P.error) () ||])

tranche1Trigger :: Vesting -> EventTrigger
tranche1Trigger v =
    let VestingTranche dt1 _ = vestingTranche1 v in
    (slotRangeT (singleton dt1))

-- | Collect the remaining funds at the end of tranche 2
tranche2Handler :: MonadWallet m => Vesting -> EventHandler m
tranche2Handler vesting = EventHandler (\_ -> do
    logMsg "Collecting tranche 2"
    let vlscript = validatorScript vesting
        redeemerScript  = Ledger.unitRedeemer
        VestingTranche dt2 _ = vestingTranche2 vesting
        range = intervalFrom dt2
    collectFromScript range vlscript redeemerScript)

tranche2Trigger :: Vesting -> EventTrigger
tranche2Trigger v =
    let VestingTranche dt2 _ = vestingTranche2 v in
    (slotRangeT (singleton dt2))

$(mkFunctions ['vestFunds, 'registerVestingOwner])

Simulation.json

{"wallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getAda":10}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getAda":10}}],"sourceCode":"-- | Vesting scheme as a PLC contract\nmodule Vesting where\n\nimport           Control.Monad                (void)\n\nimport qualified Language.PlutusTx            as PlutusTx\nimport qualified Ledger.Interval              as Interval\nimport qualified Language.PlutusTx.Prelude    as P\nimport           Ledger\nimport           Ledger.Ada                   (Ada)\nimport qualified Ledger.Ada.TH                as Ada\nimport           Ledger.Validation\nimport           Wallet\nimport           Playground.Contract\n\n-- | Tranche of a vesting scheme.\ndata VestingTranche = VestingTranche {\n    vestingTrancheDate   :: Slot,\n    vestingTrancheAmount :: Ada\n    } deriving (Generic, ToJSON, FromJSON, ToSchema)\n\nPlutusTx.makeLift ''VestingTranche\n\n-- | A vesting scheme consisting of two tranches. Each tranche defines a date\n--   (slot) after which an additional amount of money can be spent.\ndata Vesting = Vesting {\n    vestingTranche1 :: VestingTranche,\n    vestingTranche2 :: VestingTranche,\n    vestingOwner    :: PubKey\n    } deriving (Generic, ToJSON, FromJSON, ToSchema)\n\nPlutusTx.makeLift ''Vesting\n\n-- | The total amount of money vested\ntotalAmount :: Vesting -> Ada\ntotalAmount Vesting{..} =\n    vestingTrancheAmount vestingTranche1 + vestingTrancheAmount vestingTranche2\n\n-- | Data script for vesting utxo\ndata VestingData = VestingData {\n    vestingDataHash    :: ValidatorHash, -- ^ Hash of the validator script\n    vestingDataPaidOut :: Ada -- ^ How much of the vested value has already been retrieved\n    } deriving (Eq, Generic, ToJSON, FromJSON, ToSchema)\n\nPlutusTx.makeLift ''VestingData\n\n-- | Lock some funds with the vesting validator script and return a\n--   [[VestingData]] representing the current state of the process\nvestFunds :: MonadWallet m => Vesting -> Ada -> m ()\nvestFunds vst adaAmount = do\n    _ <- if adaAmount < totalAmount vst then throwOtherError \"Value must not be smaller than vested amount\" else pure ()\n    let value = $$(Ada.toValue) adaAmount\n    (payment, change) <- createPaymentWithChange value\n    let contractAddress = Ledger.scriptAddress (validatorScript vst)\n        dataScript      = DataScript (Ledger.lifted vd)\n        vd =  VestingData (validatorScriptHash vst) 0\n    payToScript_ defaultSlotRange contractAddress value dataScript\n\n-- | Register this wallet as the owner of the vesting scheme. At each of the\n--   two dates (tranche 1, tranche 2) we take out the funds that have been\n--   released so far.\n--   This function has to be called before the funds are vested, so that the\n--   wallet can start watching the contract address for changes.\nregisterVestingOwner :: MonadWallet m => Vesting -> m ()\nregisterVestingOwner v = do\n    ourPubKey <- ownPubKey\n    let\n        o = vestingOwner v\n        addr = Ledger.scriptAddress (validatorScript v)\n    _ <- if o /= ourPubKey\n         then throwOtherError \"Vesting scheme is not owned by this wallet\"\n         else startWatching addr\n\n    register (tranche2Trigger v) (tranche2Handler v)\n    -- ^ This runs `tranche2Handler` as soon as the final funds are released.\n    --   It is possible to take out funds from tranche 1 earlier than that\n    --   (as explained in the script code, below) but doing so requires some\n    --   low-level code dealing with the transaction outputs, because we don't\n    --   have a nice interface for this in 'Wallet.API' yet.\n\n\nvalidatorScriptHash :: Vesting -> ValidatorHash\nvalidatorScriptHash =\n    plcValidatorDigest\n    . Ledger.getAddress\n    . Ledger.scriptAddress\n    . validatorScript\n\nvalidatorScript :: Vesting -> ValidatorScript\nvalidatorScript v = ValidatorScript val where\n    val = Ledger.applyScript inner (Ledger.lifted v)\n    inner = $$(Ledger.compileScript [|| \\Vesting{..} () VestingData{..} (p :: PendingTx) ->\n        let\n\n            eqPk :: PubKey -> PubKey -> Bool\n            eqPk = $$(eqPubKey)\n\n            infixr 3 &&\n            (&&) :: Bool -> Bool -> Bool\n            (&&) = $$(P.and)\n\n            PendingTx _ os _ _ _ range = p\n            VestingTranche d1 a1 = vestingTranche1\n            VestingTranche d2 a2 = vestingTranche2\n\n            -- We assume here that the txn outputs are always given in the same\n            -- order (1 PubKey output, followed by 0 or 1 script outputs)\n            amountSpent :: Ada\n            amountSpent = case os of\n                PendingTxOut v' _ (PubKeyTxOut pk):_\n                    | pk `eqPk` vestingOwner -> $$(Ada.fromValue) v'\n                _ -> $$(P.error) ()\n\n            -- Value that has been released so far under the scheme\n            currentThreshold =\n                if $$(Interval.contains) ($$(Interval.from) d1) range\n                then if $$(Interval.contains) ($$(Interval.from) d2) range\n                    -- everything can be spent\n                        then $$(Ada.plus) a1 a2\n                        -- only the first tranche can be spent (we are between d1 and d2)\n                        else a1\n                -- Nothing has been released yet\n                else $$(Ada.zero)\n\n\n            paidOut = vestingDataPaidOut\n            newAmount = $$(Ada.plus) paidOut amountSpent\n\n            -- Verify that the amount taken out, plus the amount already taken\n            -- out before, does not exceed the threshold that is currently\n            -- allowed\n            amountsValid = $$(Ada.leq) newAmount currentThreshold\n\n            -- Check that the remaining output is locked by the same validation\n            -- script\n            txnOutputsValid = case os of\n                _:PendingTxOut _ (Just (vl', _)) DataTxOut:_ -> $$(eqValidator) vl' vestingDataHash\n                -- If there is no data script in the output list,\n                -- we only accept the transaction if we are past the\n                -- date of the final tranche.\n                _ -> $$(Interval.before) d2 range\n\n            isValid = amountsValid && txnOutputsValid\n        in\n        if isValid then () else $$(P.error) () ||])\n\ntranche1Trigger :: Vesting -> EventTrigger\ntranche1Trigger v =\n    let VestingTranche dt1 _ = vestingTranche1 v in\n    (slotRangeT (singleton dt1))\n\n-- | Collect the remaining funds at the end of tranche 2\ntranche2Handler :: MonadWallet m => Vesting -> EventHandler m\ntranche2Handler vesting = EventHandler (\\_ -> do\n    logMsg \"Collecting tranche 2\"\n    let vlscript = validatorScript vesting\n        redeemerScript  = Ledger.unitRedeemer\n        VestingTranche dt2 _ = vestingTranche2 vesting\n        range = intervalFrom dt2\n    collectFromScript range vlscript redeemerScript)\n\ntranche2Trigger :: Vesting -> EventTrigger\ntranche2Trigger v =\n    let VestingTranche dt2 _ = vestingTranche2 v in\n    (slotRangeT (singleton dt2))\n\n$(mkFunctions ['vestFunds, 'registerVestingOwner])\n","program":[{"blocks":10,"tag":"Wait"},{"wallet":{"getWallet":1},"function":"payToPublicKey_","arguments":["{\"ivTo\":{\"getSlot\":50},\"ivFrom\":{\"getSlot\":0}}","{\"getValue\":[[0,3]]}","{\"getPubKey\":2}"],"tag":"Action"}],"blockchain":[]}