Plutus Playground Smart Contract

Playground.hs

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TemplateHaskell    #-}
import           Control.Applicative                  (Applicative (pure))
import           Control.Monad                        (void)
import           Language.Plutus.Contract
import qualified Language.Plutus.Contract.Constraints as Constraints
import qualified Language.Plutus.Contract.Typed.Tx    as Typed
import qualified Language.PlutusTx                    as PlutusTx
import           Language.PlutusTx.Prelude            hiding (Applicative (..), Semigroup (..))
import           Ledger                               (PubKeyHash, TxInfo (..), Validator, ValidatorCtx (..),
                                                       pubKeyHash, txId, valueSpent)
import qualified Ledger                               as Ledger
import qualified Ledger.Ada                           as Ada
import qualified Ledger.Contexts                      as V
import qualified Ledger.Interval                      as Interval
import qualified Ledger.Scripts                       as Scripts
import           Ledger.Slot                          (Slot, SlotRange)
import qualified Ledger.Typed.Scripts                 as Scripts
import           Ledger.Value                         (Value)
import qualified Ledger.Value                         as Value
import           Playground.Contract
import           Prelude                              (Semigroup (..))
import qualified Prelude                              as Haskell
import qualified Wallet.Emulator                      as Emulator
import           Language.PlutusTx.Coordination.Contracts.Escrow (EscrowParams (..))
import qualified Language.PlutusTx.Coordination.Contracts.Escrow as Escrow
import           Ledger            (PubKey, Value)
import           Wallet.Emulator.Types    (Wallet, walletPubKey)
import           Control.Lens.TH                     (makeClassyPrisms)

-- | Describes an exchange of two
--   'Value' amounts between two parties
--   identified by public keys
data AtomicSwapParams =
    AtomicSwapParams
        { ada          :: Value -- ^ The amount paid to the hash of 'party1'
        , currencyHash :: Value.CurrencySymbol
        , tokenName    :: TokenName
        , amount       :: Integer
        , party1       :: Wallet -- ^ The first party in the atomic swap
        , party2       :: Wallet -- ^ The second party in the atomic swap
        , deadline     :: Slot -- ^ Last slot in which the swap can be executed.
        }
        deriving stock (Show, Generic)
        deriving anyclass (ToJSON, FromJSON, ToSchema)

mkValue1 :: AtomicSwapParams -> Value
mkValue1 = ada

mkValue2 :: AtomicSwapParams -> Value
mkValue2 AtomicSwapParams{currencyHash, tokenName, amount} =
    Value.singleton currencyHash tokenName amount

mkEscrowParams :: AtomicSwapParams -> EscrowParams t
mkEscrowParams p@AtomicSwapParams{party1,party2,deadline} =
    let pubKey1 = walletPubKey party1
        pubKey2 = walletPubKey party2
        value1 = mkValue1 p
        value2 = mkValue2 p
    in EscrowParams
        { escrowDeadline = deadline
        , escrowTargets =
                [ Escrow.payToPubKeyTarget (Ledger.pubKeyHash pubKey1) value1
                , Escrow.payToPubKeyTarget (Ledger.pubKeyHash pubKey2) value2
                ]
        }

type AtomicSwapSchema =
    BlockchainActions
        .\/ Endpoint "Atomic swap" AtomicSwapParams

data AtomicSwapError =
    EscrowError Escrow.EscrowError
    | OtherAtomicSwapError ContractError
    | NotInvolvedError PubKey AtomicSwapParams -- ^ When the wallet's public key doesn't match either of the two keys specified in the 'AtomicSwapParams'
    deriving (Show)

makeClassyPrisms ''AtomicSwapError
instance AsContractError AtomicSwapError where
    _ContractError = _OtherAtomicSwapError


-- | Perform the atomic swap. Needs to be called by both of the two parties
--   involved.
atomicSwap :: Contract AtomicSwapSchema AtomicSwapError ()
atomicSwap = do
    p <- endpoint @"Atomic swap"
    let value1 = mkValue1 p
        value2 = mkValue2 p
        params = mkEscrowParams p

        go pk
            | pk == walletPubKey (party1 p) =
                -- there are two paying transactions and one redeeming transaction.
                -- The redeeming tx is submitted by party 1.
                -- TODO: Change 'payRedeemRefund' to check before paying into the
                -- address, so that the last paying transaction can also be the
                -- redeeming transaction.
                void $ mapError EscrowError (Escrow.payRedeemRefund params value2)
            | pk == walletPubKey (party2 p) =
                void $ mapError EscrowError (Escrow.pay (Escrow.scriptInstance params) params value1) >>= awaitTxConfirmed
            | otherwise = throwError (NotInvolvedError pk p)

    ownPubKey >>= go

endpoints :: Contract AtomicSwapSchema AtomicSwapError ()
endpoints = atomicSwap

mkSchemaDefinitions ''AtomicSwapSchema

myCurrency :: KnownCurrency
myCurrency = KnownCurrency (ValidatorHash "") "MyCurrency" (TokenName "MyToken" :| [])

$(mkKnownCurrencies ['myCurrency])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10],[{"unTokenName":"MyToken"},10]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10],[{"unTokenName":"MyToken"},10]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[]}]]