Plutus Playground Smart Contract

Playground.hs

{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TemplateHaskell    #-}
-- Otherwise we get a complaint about the 'fromIntegral' call in the generated instance of 'Integral' for 'Ada'
{-# OPTIONS_GHC -Wno-identities #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
-- This is a starter contract, based on the Game contract,
-- containing the bare minimum required scaffolding.
--
-- What you should change to something more suitable for
-- your use case:
--   * The DataScript type
--   * The Redeemer type
--
-- And add function implementations (and rename them to
-- something suitable) for the endpoints:
--   * publish
--   * redeem
import           Control.Applicative       (liftA2)
import qualified Language.PlutusTx          as PlutusTx
import           Language.PlutusTx.Prelude
import           Ledger                    (Address, DataScript (DataScript), PendingTx, PubKey,
                                            RedeemerScript (RedeemerScript), TxId, ValidatorScript (ValidatorScript),
                                            applyScript, compileScript, hashTx, lifted, pendingTxValidRange,
                                            scriptAddress, valueSpent)
import qualified Ledger.Ada                as Ada
import qualified Ledger.Interval           as Interval
import           Ledger.Slot               (Slot, SlotRange)
import qualified Ledger.Validation         as V
import           Ledger.Value               (Value, CurrencySymbol)
import           Playground.Contract
import           Wallet                     (MonadWallet, WalletAPI, WalletDiagnostics, collectFromScript,
                                             defaultSlotRange, payToScript_, startWatching)
import qualified Wallet                    as W
import           Wallet.Emulator           (Wallet)
import qualified Wallet.Emulator           as EM


myToken :: KnownCurrency
myToken = KnownCurrency "b0b0" "MyToken" ("MyToken" :| [])
$(mkKnownCurrencies ['myToken])

-----------------------------------------------------------------------------------------------

-- escrow code

data EscrowAgreement = EscrowAgreement
    { seller :: PubKey
    , buyer :: PubKey
    , sellerValue :: Value -- value posted by seller / refunded to seller
    , buyerValue :: Value -- value posted by buyer / refunded to buyer
    , depositDeadline :: Slot
    , distributionDeadline :: Slot
    } deriving (Generic, ToJSON, FromJSON, ToSchema)
    
PlutusTx.makeLift ''EscrowAgreement

mkEscrowContract :: Wallet -> Wallet -> Value -> Value -> Slot -> Slot -> EscrowAgreement
mkEscrowContract sellerWallet buyerWallet sellerValue_ buyerValue_ depositDdl distDdl =
    EscrowAgreement
        { seller = EM.walletPubKey sellerWallet
        , buyer  = EM.walletPubKey buyerWallet
        , sellerValue = sellerValue_
        , buyerValue = buyerValue_
        , depositDeadline = depositDdl
        , distributionDeadline = distDdl
        }

distributionRange :: EscrowAgreement -> SlotRange
distributionRange = liftA2 W.interval depositDeadline distributionDeadline
    
refundRange :: EscrowAgreement -> SlotRange
refundRange = W.intervalFrom . distributionDeadline

data ResolveAction = Distribute | Refund
    deriving (Generic, ToJSON, FromJSON, ToSchema)
    
PlutusTx.makeLift ''ResolveAction

type EscrowValidator = (PubKey, PubKey) -> ResolveAction -> PendingTx -> Bool

validRefund :: EscrowAgreement -> PubKey -> PendingTx -> Bool
validRefund esc party ptx =
    -- Check that the transaction falls in the refund range of the campaign
    Interval.contains (refundRange esc) (pendingTxValidRange ptx)
    -- Check that the transaction is signed by the contributor
    && (if
        | party == seller esc -> ptx `V.txSignedBy` party
        | party == buyer esc -> ptx `V.txSignedBy` party
        | otherwise -> False)
        
validDistribution :: EscrowAgreement -> PendingTx -> Bool
validDistribution esc ptx =
    -- Check that the transaction falls in the distribution range range of the campaign
    Interval.contains (distributionRange esc) (pendingTxValidRange ptx)
    -- Check that the transaction is signed by the contributor and that they are attempting to withdraw the correct side
    && V.valuePaidTo ptx (seller esc) `V.geq` buyerValue esc
    && V.valuePaidTo ptx (buyer esc) `V.geq` sellerValue esc
    && V.valueSpent ptx == (sellerValue esc <> buyerValue esc)
        
mkValidator :: EscrowAgreement -> EscrowValidator
mkValidator esc (contributor, counterParty) resolutionAction ptx = case resolutionAction of
    -- the "refund" branch
    Refund -> validRefund esc contributor ptx
    -- the "distribution" branch
    Distribute -> validDistribution esc ptx
        
escrowScript :: EscrowAgreement -> ValidatorScript
escrowScript esc  = ValidatorScript $
    $$(Ledger.compileScript [|| mkValidator ||])
        `Ledger.applyScript`
            Ledger.lifted esc
            
escrowAddress :: EscrowAgreement -> Ledger.Address
escrowAddress = Ledger.scriptAddress . escrowScript

buyerDeposit :: MonadWallet m => Wallet -> Wallet -> Value -> Value -> Slot -> Slot -> m ()
buyerDeposit sellerW buyerW sellerAmt buyerAmt depDdl distDdl = do
    let contract = mkEscrowContract sellerW buyerW sellerAmt buyerAmt depDdl distDdl
    ownPK <- W.ownPubKey
    let ds = DataScript (Ledger.lifted ownPK)
        range = W.interval 1 depDdl

    -- `payToScript` is a function of the wallet API. It takes a campaign
    -- address, value, and data script, and generates a transaction that
    -- pays the value to the script. `tx` is bound to this transaction. We need
    -- to hold on to it because we are going to use it in the refund handler.
    -- If we were not interested in the transaction produced by `payToScript`
    -- we could have used `payeToScript_`, which has the same effect but
    -- discards the result.
    tx <- W.payToScript range (escrowAddress contract) buyerAmt ds

    W.logMsg "Submitted deposit"

    -- `register` adds a blockchain event handler on the `refundTrigger`
    -- event. It instructs the wallet to start watching the addresses mentioned
    -- in the trigger definition and run the handler when the refund condition
    -- is true.
    W.register (refundTrigger buyerAmt contract) (refundHandler (Ledger.hashTx tx) contract)

    W.logMsg "Registered refund trigger"
    
sellerDeposit :: MonadWallet m => Wallet -> Wallet -> Value -> Value -> Slot -> Slot -> m ()
sellerDeposit sellerW buyerW sellerAmt buyerAmt depDdl distDdl = do
    let contract = mkEscrowContract sellerW buyerW sellerAmt buyerAmt depDdl distDdl
    ownPK <- W.ownPubKey
    let ds = DataScript (Ledger.lifted ownPK)
        range = W.interval 1 depDdl

    -- `payToScript` is a function of the wallet API. It takes a campaign
    -- address, value, and data script, and generates a transaction that
    -- pays the value to the script. `tx` is bound to this transaction. We need
    -- to hold on to it because we are going to use it in the refund handler.
    -- If we were not interested in the transaction produced by `payToScript`
    -- we could have used `payeToScript_`, which has the same effect but
    -- discards the result.
    tx <- W.payToScript range (escrowAddress contract) sellerAmt ds

    W.logMsg "Submitted deposit"

    -- `register` adds a blockchain event handler on the `refundTrigger`
    -- event. It instructs the wallet to start watching the addresses mentioned
    -- in the trigger definition and run the handler when the refund condition
    -- is true.
    W.register (refundTrigger sellerAmt contract) (refundHandler (Ledger.hashTx tx) contract)

    W.logMsg "Registered refund trigger"
    
scheduleDistribution :: MonadWallet m => Wallet -> Wallet -> Value -> Value -> Slot -> Slot -> m ()
scheduleDistribution sellerW buyerW sellerAmt buyerAmt depDdl distDdl = do
    let contract = mkEscrowContract sellerW buyerW sellerAmt buyerAmt depDdl distDdl
    W.register (distributeFundsTrigger contract) (W.EventHandler (\_ -> do
        W.logMsg "Distributing funds"
        let redeemerScript = Ledger.RedeemerScript (Ledger.lifted Distribute)
            range = distributionRange contract

        let addr = escrowAddress contract
        outs <- W.spendScriptOutputs addr (escrowScript contract) redeemerScript
        filter outs 
        ))
        
-- | An event trigger that fires when a refund of campaign contributions
-- can be claimed
refundTrigger :: Value -> EscrowAgreement -> W.EventTrigger
refundTrigger vl esc = W.andT
    (W.fundsAtAddressGeqT (escrowAddress esc) vl)
    (W.slotRangeT (refundRange esc))

-- | An event trigger that fires when the funds for a campaign can be collected
distributeFundsTrigger :: EscrowAgreement -> W.EventTrigger
distributeFundsTrigger esc = W.andT
    (W.fundsAtAddressGeqT (escrowAddress esc) (liftA2 (<>) sellerValue buyerValue esc))
    (W.slotRangeT (distributionRange esc))

-- | Claim a refund of our campaign contribution
refundHandler :: MonadWallet m => TxId -> EscrowAgreement -> W.EventHandler m
refundHandler txid esc = W.EventHandler (\_ -> do
    W.logMsg "Claiming refund"
    let validatorScript = escrowScript esc
        redeemerScript  = Ledger.RedeemerScript (Ledger.lifted Refund)

    -- `collectFromScriptTxn` generates a transaction that spends the unspent
    -- transaction outputs at the address of the validator scripts, *but* only
    -- those outputs that were produced by the transaction `txid`. We use it
    -- here to ensure that we don't attempt to claim back other contributors'
    -- funds (if we did that, the validator script would fail and the entire
    -- transaction would be invalid).
    W.collectFromScriptTxn (refundRange esc) validatorScript redeemerScript txid)
        
$(mkFunctions ['buyerDeposit, 'sellerDeposit, 'scheduleDistribution])

Simulation.json

[0,[]]