Plutus Playground Smart Contract

Playground.hs

{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE TypeApplications #-}
{-# 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, empty)
import           Control.Monad             (guard, void)
import           Control.Monad.Trans.Reader
import qualified Data.Aeson as Aeson
import           Data.Functor              (($>))
import qualified Data.Set                     as Set
import qualified Data.Text                    as Text
import qualified Language.PlutusTx          as PlutusTx
import           Language.PlutusTx.Prelude hiding (check)
import           Ledger                    hiding (to)
import qualified Ledger.Ada                as Ada
import qualified Ledger.Interval           as Interval
import           Ledger.Slot               (Slot, SlotRange)
-- import qualified Ledger.Typed.Tx              as Typed
import qualified Ledger.Validation         as V
import           Ledger.Value               (Value, CurrencySymbol, geq, singleton)
import           Playground.Contract
import           Wallet                     (MonadWallet, WalletAPI, WalletDiagnostics, collectFromScript,
                                             defaultSlotRange, payToScript_, startWatching)
import qualified Wallet                    as W
import qualified Wallet.Typed.API          as WTyped
import           Wallet.Emulator           (Wallet)
import qualified Wallet.Emulator           as EM

import qualified Language.PlutusTx.StateMachine as SM
import           Language.PlutusTx.StateMachine (StateMachine(..))
import qualified Wallet.Typed.StateMachine as SM
import Schema

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

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

-- escrow code

data EmulatorParams = EmulatorParams
    { eSeller :: Wallet
    , eBuyer :: Wallet
    , eSellerVal :: Value
    , eBuyerVal :: Value
    , eDepositDeadline :: Slot
    } deriving (Generic, ToJSON, FromJSON, ToSchema)

data EscrowParams = EscrowParams
    { seller :: PubKey
    , buyer :: PubKey
    , sellerVal :: Value
    , buyerVal :: Value
    , depositDeadline :: Slot
    } deriving (Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeLift ''EscrowParams

emulate :: EmulatorParams -> EscrowParams
emulate EmulatorParams{..} = EscrowParams{..}
    where
        seller = EM.walletPubKey eSeller
        buyer = EM.walletPubKey eBuyer
        sellerVal = eSellerVal
        buyerVal = eBuyerVal
        depositDeadline = eDepositDeadline

data EscrowState =
      Empty
    | Initialized TokenName
    | SellerDepositComplete TokenName
    | BuyerDepositComplete TokenName
    | BothDepositsComplete TokenName
    | SellerWithdrawalComplete TokenName
    | BuyerWithdrawalComplete TokenName
    | BothWithdrawalsComplete TokenName -- terminal
    | Refunded TokenName -- terminal
    deriving (Generic, Show, ToJSON)
    
instance Eq EscrowState where
    {-# INLINABLE (==) #-}
    Empty == Empty = True
    Initialized a == Initialized b = a == b
    SellerDepositComplete a == SellerDepositComplete b = a == b
    BuyerDepositComplete a == BuyerDepositComplete b = a == b
    BothDepositsComplete a == BothDepositsComplete b = a == b
    SellerWithdrawalComplete a == SellerWithdrawalComplete b = a == b
    BuyerWithdrawalComplete a == BuyerWithdrawalComplete b = a == b
    BothWithdrawalsComplete a == BothWithdrawalsComplete b = a == b
    Refunded a == Refunded b = a == b
    _ == _ = traceIfFalseH "states not equal" False
    
instance FromJSON EscrowState where
    parseJSON = Aeson.withText "Escrow State" $ \t -> case t of
        "Empty" -> pure Empty
        "Initialized" -> pure $ Initialized escrowToken
        "SellerDepositComplete" -> pure $ SellerDepositComplete escrowToken
        "BuyerDepositComplete" -> pure $ BuyerDepositComplete escrowToken
        "BothDepositsComplete" -> pure $ BothDepositsComplete escrowToken
        "SellerWithdrawalComplete" -> pure $ SellerWithdrawalComplete escrowToken
        "BuyerWithdrawalComplete" -> pure $ BuyerWithdrawalComplete escrowToken
        "BothWithdrawalsComplete" -> pure $ BothWithdrawalsComplete escrowToken
        "Refunded" -> pure $ Refunded escrowToken
        _ -> fail $ "Invalid Escrow State: " <> Text.unpack t
        where
            escrowToken = "escrow"
instance ToSchema EscrowState where
    toSchema = FormSchemaRadio
        [ "Empty"
        , "Initialized"
        , "SellerDepositComplete"
        , "BuyerDepositComplete"
        , "BothDepositsComplete"
        , "SellerWithdrawalComplete"
        , "BuyerWithdrawalComplete"
        , "BothWithdrawalsComplete"
        , "Refunded"
        ]

PlutusTx.makeLift ''EscrowState

data EscrowAction =
      ForgeToken TokenName
    | Deposit PubKey
    | Withdraw PubKey
    deriving (Show)
    

PlutusTx.makeLift ''EscrowAction

{-# INLINABLE pubKey #-}
pubKey :: Wallet -> PubKey
pubKey = EM.walletPubKey

{-# INLINABLE refundRange #-}
refundRange :: EscrowParams -> SlotRange
refundRange = Interval.from . depositDeadline

{-# INLINABLE step #-}
step :: EscrowParams -> EscrowState -> EscrowAction -> Maybe EscrowState
step EscrowParams{..} state input =
    case (state, input) of
        (Empty, ForgeToken tn) -> pure $ Initialized tn
        (Initialized tn, Deposit pub) -> if
            | pub == seller -> pure $ SellerDepositComplete tn
            | pub == buyer -> pure $ BuyerDepositComplete tn
            | otherwise -> empty
        (SellerDepositComplete tn, Deposit pub)  -> guard (pub == buyer)  $> BothDepositsComplete tn
        (SellerDepositComplete tn, Withdraw pub) -> guard (pub == seller) $> Refunded tn
        (BuyerDepositComplete tn,  Deposit pub)  -> guard (pub == seller) $> BothDepositsComplete tn
        (BuyerDepositComplete tn,  Withdraw pub) -> guard (pub == buyer)  $> Refunded tn
        (BothDepositsComplete tn, Withdraw pub) -> if
            | pub == seller -> pure $ SellerWithdrawalComplete tn
            | pub == buyer -> pure $ BuyerWithdrawalComplete tn
            | otherwise -> empty
        (SellerWithdrawalComplete tn, Withdraw pub) -> guard (pub == buyer) $> BothWithdrawalsComplete tn
        (BuyerWithdrawalComplete tn, Withdraw pub) -> guard (pub == seller) $> BothWithdrawalsComplete tn
        _ -> empty
    
{-# INLINABLE check #-}
check :: EscrowParams -> EscrowState -> EscrowAction -> PendingTx -> Bool
check EscrowParams{..} state action ptx = case (state, action) of
    (Empty, ForgeToken tn) -> checkForge (tokenVal tn)
    (Initialized tn, Deposit pub) ->
        ptx `V.txSignedBy` pub && -- authenticate
        V.valueSpent ptx `geq` tokenVal tn && -- token moves for linearity
        depositDeadline `Interval.after` pendingTxValidRange ptx && -- deposits happen before deadline
        if  | pub == seller -> V.valueLockedBy ptx (V.ownHash ptx) == (sellerVal <> tokenVal tn) -- seller deposits exactly seller val
            | pub == buyer -> V.valueLockedBy ptx (V.ownHash ptx) == (buyerVal <> tokenVal tn) -- buyer deposits exactly buyer val
            | otherwise -> False
    (SellerDepositComplete tn, Deposit pub)  ->
        ptx `V.txSignedBy` pub && -- authenticate
        valueSpent ptx `geq` tokenVal tn && -- token moves for linearity
        depositDeadline `Interval.after` pendingTxValidRange ptx && -- deposit before deadline
        pub == buyer && -- only buyer can deposit
        V.valueLockedBy ptx (V.ownHash ptx) == (buyerVal <> tokenVal tn) -- buyer deposits exactly buyer val
    (SellerDepositComplete tn, Withdraw pub) ->
        ptx `V.txSignedBy` pub && -- authenticate
        valueSpent ptx `geq` tokenVal tn && -- token moves for linearity
        depositDeadline `Interval.before` pendingTxValidRange ptx && -- refund after deadline
        pub == seller && -- only seller can refund
        V.valueLockedBy ptx (V.ownHash ptx) == tokenVal tn -- token stays
    (BuyerDepositComplete tn,  Deposit pub)  -> 
        ptx `V.txSignedBy` pub &&
        valueSpent ptx `geq` tokenVal tn &&
        depositDeadline `Interval.after` pendingTxValidRange ptx &&
        pub == seller &&
        V.valueLockedBy ptx (V.ownHash ptx) == (sellerVal <> tokenVal tn)
    (BuyerDepositComplete tn,  Withdraw pub) ->
        ptx `V.txSignedBy` pub &&
        valueSpent ptx `geq` tokenVal tn &&
        depositDeadline `Interval.before` pendingTxValidRange ptx &&
        pub == buyer &&
        V.valueLockedBy ptx (V.ownHash ptx) == tokenVal tn
    (BothDepositsComplete tn, Withdraw pub) ->
        ptx `V.txSignedBy` pub &&
        if  | pub == seller -> V.valueLockedBy ptx (V.ownHash ptx) == (sellerVal <> tokenVal tn) &&
                V.valueSpent ptx == (buyerVal <> tokenVal tn)
            | pub == buyer -> V.valueLockedBy ptx (V.ownHash ptx) == (buyerVal <> tokenVal tn) &&
                V.valueSpent ptx == (sellerVal <> tokenVal tn)
            | otherwise -> False
    (SellerWithdrawalComplete tn, Withdraw pub) ->
        ptx `V.txSignedBy` pub &&
        V.valueSpent ptx == (sellerVal <> tokenVal tn) &&
        pub == buyer &&
        V.valueLockedBy ptx (V.ownHash ptx) == tokenVal tn
    (BuyerWithdrawalComplete tn, Withdraw pub) ->
        ptx `V.txSignedBy` pub &&
        V.valueSpent ptx == (buyerVal <> tokenVal tn) &&
        pub == seller &&
        V.valueLockedBy ptx (V.ownHash ptx) == tokenVal tn
    _ -> False
    where
        -- | Given a 'TokeName', get the value that contains
        --   exactly one token of that name in the contract's
        --   currency.
        tokenVal :: TokenName -> Value
        tokenVal tn =
            let ownSymbol = V.ownCurrencySymbol ptx
            in Ledger.Value.singleton ownSymbol tn 1
        -- | Check whether the token that was forged at the beginning of the
        --   contract is present in the pending transaction
        tokenPresent :: TokenName -> Bool
        tokenPresent tn =
            let vSpent = valueSpent ptx
            in  geq vSpent (tokenVal tn)
        -- | Check whether the value forged by the  pending transaction 'p' is
        --   equal to the argument.
        checkForge :: Value -> Bool
        checkForge vl = vl == V.pendingTxForge ptx
        
{-# INLINABLE final #-}
final :: EscrowState -> Bool
final (Refunded _) = True
final (BothWithdrawalsComplete _) = True
final _ = False

{-# INLINABLE mkValidator #-}  
mkValidator :: EscrowParams -> SM.StateMachineValidator EscrowState EscrowAction
mkValidator params = SM.mkValidator $ SM.StateMachine (step params) (check params) final

{-# INLINABLE escrowToken #-}
escrowToken :: TokenName
escrowToken = "escrow"

{-# INLINABLE escrowTokenVal #-}
escrowTokenVal :: EscrowParams -> Value
escrowTokenVal params =
    let cur = V.plcCurrencySymbol (Ledger.scriptAddress $ escrowValidator params)
    in Ledger.Value.singleton cur escrowToken 1

escrowValidator :: EscrowParams -> ValidatorScript
escrowValidator params = ValidatorScript $ $$(Ledger.compileScript [|| mkValidator ||]) `Ledger.applyScript` Ledger.lifted params

-- | Start watching the contract address
newEscrow :: MonadWallet m => EmulatorParams -> m ()
newEscrow params = W.startWatching . Ledger.scriptAddress . escrowValidator . emulate $ params

makeEmpty :: (WalletAPI m, WalletDiagnostics m) => EmulatorParams -> m ()
makeEmpty params = do
    (tx, state) <- SM.mkInitialise (machineInstance $ emulate params) Empty mempty
    void $ WTyped.signTxAndSubmit tx
    pure ()

forgeToken :: (WalletAPI m, WalletDiagnostics m) => EmulatorParams -> EscrowState -> m ()
forgeToken params st = do
    (scriptTx, newState) <- SM.mkStep (machineInstance $ emulate params) st (ForgeToken escrowToken) id

    let scriptOut = scriptTxOut
            (escrowTokenVal $ emulate params)
            (escrowValidator $ emulate params)
            (DataScript (Ledger.lifted newState))
    -- Need to match to get the existential type out
    

    pure ()

deposit :: (WalletAPI m, WalletDiagnostics m) => EmulatorParams -> EscrowState -> Wallet -> m ()
deposit params st = pure . pure $ ()

mkRedeemer :: EscrowAction -> RedeemerScript
mkRedeemer i = RedeemerScript $
    $$(Ledger.compileScript [|| SM.mkStepRedeemer @EscrowState @EscrowAction ||])
        `Ledger.applyScript`
            (Ledger.lifted i)
    
$(mkFunctions ['newEscrow, 'makeEmpty, 'forgeToken, 'deposit])

Simulation.json

[0,[]]