Skip to content

Commit

Permalink
SCP-2372: Uniswap trace and scripts (#3370)
Browse files Browse the repository at this point in the history
* SCP-2372: Uniswap trace and scripts
  • Loading branch information
j-mueller authored Jun 15, 2021
1 parent 19aa855 commit fdd2ac6
Show file tree
Hide file tree
Showing 12 changed files with 148 additions and 87 deletions.

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

6 changes: 3 additions & 3 deletions plutus-pab/examples/uniswap/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -29,6 +29,7 @@ import Ledger.Ada (adaSymbol, adaToken)
import Plutus.Contract
import qualified Plutus.Contracts.Currency as Currency
import qualified Plutus.Contracts.Uniswap as Uniswap
import Plutus.Contracts.Uniswap.Trace as US
import Plutus.PAB.Effects.Contract (ContractEffect (..))
import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), type (.\\))
import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin
Expand All @@ -38,7 +39,6 @@ import qualified Plutus.PAB.Simulator as Simulator
import Plutus.PAB.Types (PABError (..))
import qualified Plutus.PAB.Webserver.Server as PAB.Server
import Prelude hiding (init)
import Uniswap as US
import Wallet.Emulator.Types (Wallet (..))

main :: IO ()
Expand All @@ -63,7 +63,7 @@ main = void $ Simulator.runSimulationWith handlers $ do
_ -> Nothing
logString @(Builtin UniswapContracts) $ "Uniswap instance created: " ++ show us

cids <- fmap Map.fromList $ forM wallets $ \w -> do
cids <- fmap Map.fromList $ forM US.wallets $ \w -> do
cid <- Simulator.activateContract w $ UniswapUser us
logString @(Builtin UniswapContracts) $ "Uniswap user contract started for " ++ show w
Simulator.waitForEndpoint cid "funds"
Expand Down Expand Up @@ -111,7 +111,7 @@ handleUniswapContract = Builtin.handleBuiltin getSchema getContract where
getContract = \case
UniswapUser us -> SomeBuiltin $ Uniswap.userEndpoints us
UniswapStart -> SomeBuiltin Uniswap.ownerEndpoint
Init -> SomeBuiltin US.initContract
Init -> SomeBuiltin US.setupTokens

handlers :: SimulatorEffectHandlers (Builtin UniswapContracts)
handlers =
Expand Down
43 changes: 0 additions & 43 deletions plutus-pab/examples/uniswap/Uniswap.hs

This file was deleted.

1 change: 0 additions & 1 deletion plutus-pab/plutus-pab.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -245,7 +245,6 @@ executable plutus-pab

executable plutus-uniswap
main-is: Main.hs
other-modules: Uniswap
hs-source-dirs: examples/uniswap
other-modules:
default-language: Haskell2010
Expand Down
2 changes: 2 additions & 0 deletions plutus-use-cases/plutus-use-cases.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,7 @@ library
Plutus.Contracts.Uniswap.OnChain
Plutus.Contracts.Uniswap.OffChain
Plutus.Contracts.Uniswap.Pool
Plutus.Contracts.Uniswap.Trace
Plutus.Contracts.Uniswap.Types
Plutus.Contracts.Vesting
hs-source-dirs: src
Expand Down Expand Up @@ -114,6 +115,7 @@ test-suite plutus-use-cases-test
Spec.Prism
Spec.Rollup
Spec.Stablecoin
Spec.Uniswap
Spec.TokenAccount
Spec.Vesting
default-language: Haskell2010
Expand Down
63 changes: 31 additions & 32 deletions plutus-use-cases/scripts/Main.hs
Original file line number Diff line number Diff line change
@@ -1,36 +1,36 @@
module Main(main) where

import qualified Control.Foldl as L
import Control.Monad.Freer (run)
import qualified Data.ByteString.Lazy as BSL
import Data.Default (Default (..))
import Data.Foldable (traverse_)
import Flat (flat)
import Ledger.Index (ScriptValidationEvent (sveScript))
import Plutus.Trace.Emulator (EmulatorTrace)
import qualified Plutus.Trace.Emulator as Trace
import Plutus.V1.Ledger.Scripts (Script (..))
import qualified Streaming.Prelude as S
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs)
import System.FilePath ((</>))
import qualified Wallet.Emulator.Folds as Folds
import Wallet.Emulator.Stream (foldEmulatorStreamM)
import qualified Control.Foldl as L
import Control.Monad.Freer (run)
import qualified Data.ByteString.Lazy as BSL
import Data.Default (Default (..))
import Data.Foldable (traverse_)
import Flat (flat)
import Ledger.Index (ScriptValidationEvent (sveScript))
import Plutus.Trace.Emulator (EmulatorTrace)
import qualified Plutus.Trace.Emulator as Trace
import Plutus.V1.Ledger.Scripts (Script (..))
import qualified Streaming.Prelude as S
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs)
import System.FilePath ((</>))
import qualified Wallet.Emulator.Folds as Folds
import Wallet.Emulator.Stream (foldEmulatorStreamM)

import qualified Plutus.Contracts.Crowdfunding as Crowdfunding
import Spec.Auction as Auction
import qualified Spec.Currency as Currency
import qualified Spec.Escrow as Escrow
import qualified Spec.Future as Future
import qualified Spec.GameStateMachine as GameStateMachine
import qualified Spec.MultiSig as MultiSig
import qualified Spec.MultiSigStateMachine as MultiSigStateMachine
import qualified Spec.PingPong as PingPong
import qualified Spec.Prism as Prism
import qualified Spec.PubKey as PubKey
import qualified Spec.Stablecoin as Stablecoin
import qualified Spec.TokenAccount as TokenAccount
import qualified Spec.Vesting as Vesting
import qualified Plutus.Contracts.Crowdfunding as Crowdfunding
import qualified Plutus.Contracts.Uniswap.Trace as Uniswap
import qualified Spec.Currency as Currency
import qualified Spec.Escrow as Escrow
import qualified Spec.Future as Future
import qualified Spec.GameStateMachine as GameStateMachine
import qualified Spec.MultiSig as MultiSig
import qualified Spec.MultiSigStateMachine as MultiSigStateMachine
import qualified Spec.PingPong as PingPong
import qualified Spec.Prism as Prism
import qualified Spec.PubKey as PubKey
import qualified Spec.Stablecoin as Stablecoin
import qualified Spec.TokenAccount as TokenAccount
import qualified Spec.Vesting as Vesting

main :: IO ()
main = do
Expand Down Expand Up @@ -67,8 +67,7 @@ writeScripts fp = do
, ("stablecoin_2", Stablecoin.maxReservesExceededTrace)
, ("token-account", TokenAccount.tokenAccountTrace)
, ("vesting", Vesting.retrieveFundsTrace)
, ("auction_1", Auction.auctionTrace1)
, ("auction_2", Auction.auctionTrace2)
, ("uniswap", Uniswap.uniswapTrace)
]

{-| Run an emulator trace and write the applied scripts to a file in Flat format
Expand Down
3 changes: 3 additions & 0 deletions plutus-use-cases/src/Plutus/Contracts/Uniswap.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
-- | A decentralized exchange for arbitrary token pairs following the
-- [Uniswap protocol](https://uniswap.org/whitepaper.pdf).
--
Expand All @@ -13,9 +14,11 @@ module Plutus.Contracts.Uniswap
, module OffChain
, module Types
, module Pool
, module Trace
) where

import Plutus.Contracts.Uniswap.OffChain as OffChain
import Plutus.Contracts.Uniswap.OnChain as OnChain
import Plutus.Contracts.Uniswap.Pool as Pool
import Plutus.Contracts.Uniswap.Trace as Trace
import Plutus.Contracts.Uniswap.Types as Types
11 changes: 5 additions & 6 deletions plutus-use-cases/src/Plutus/Contracts/Uniswap/OffChain.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@ import qualified Data.Map as Map
import Data.Monoid (Last (..))
import Data.Proxy (Proxy (..))
import Data.Text (Text, pack)
import Data.Void (Void)
import Data.Void (Void, absurd)
import Ledger hiding (singleton)
import Ledger.Constraints as Constraints
import qualified Ledger.Typed.Scripts as Scripts
Expand Down Expand Up @@ -488,12 +488,11 @@ findSwapB oldA oldB inB = findSwapA (switch oldB) (switch oldA) (switch inB)
where
switch = Amount . unAmount

ownerEndpoint :: Contract (Last (Either Text Uniswap)) BlockchainActions Void ()
ownerEndpoint :: Contract (Last (Either Text Uniswap)) BlockchainActions ContractError ()
ownerEndpoint = do
e <- runError start
tell $ Last $ Just $ case e of
Left err -> Left err
Right us -> Right us
e <- mapError absurd $ runError start
tell $ Last $ Just e
void $ waitNSlots 10

-- | Provides the following endpoints for users of a Uniswap instance:
--
Expand Down
84 changes: 84 additions & 0 deletions plutus-use-cases/src/Plutus/Contracts/Uniswap/Trace.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,84 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-| Example trace for the uniswap contract
-}
module Plutus.Contracts.Uniswap.Trace(
uniswapTrace
--
, setupTokens
, tokenNames
, wallets
) where

import Control.Monad (forM_, void, when)
import Control.Monad.Freer.Error (throwError)
import qualified Data.Map as Map
import qualified Data.Monoid as Monoid
import qualified Data.Semigroup as Semigroup
import Ledger
import Ledger.Ada (adaSymbol, adaToken)
import Ledger.Constraints
import Ledger.Value as Value
import Plutus.Contract hiding (throwError, when)
import qualified Plutus.Contracts.Currency as Currency
import Plutus.Contracts.Uniswap.OffChain as OffChain
import Plutus.Contracts.Uniswap.Types as Types
import Plutus.Trace.Emulator (EmulatorRuntimeError (GenericError), EmulatorTrace)
import qualified Plutus.Trace.Emulator as Emulator
import Wallet.Emulator.Types (Wallet (..), walletPubKey)

-- | Set up a liquidity pool and call the "add" endpoint
uniswapTrace :: EmulatorTrace ()
uniswapTrace = do
cidInit <- Emulator.activateContract (Wallet 1) setupTokens "init"
_ <- Emulator.waitNSlots 5
cs <- Emulator.observableState cidInit >>= \case
Just (Semigroup.Last cur) -> pure (Currency.currencySymbol cur)
_ -> throwError $ GenericError "failed to create currency"
let coins = Map.fromList [(tn, Types.mkCoin cs tn) | tn <- tokenNames]
ada = Types.mkCoin adaSymbol adaToken

cidStart <- Emulator.activateContract (Wallet 1) ownerEndpoint "start"
_ <- Emulator.waitNSlots 5
us <- Emulator.observableState cidStart >>= \case
Monoid.Last (Just (Right v)) -> pure v
_ -> throwError $ GenericError "initialisation failed"
cid1 <- Emulator.activateContractWallet (Wallet 2) (userEndpoints us)
cid2 <- Emulator.activateContractWallet (Wallet 3) (userEndpoints us)
_ <- Emulator.waitNSlots 5

let cp = OffChain.CreateParams ada (coins Map.! "A") 100000 500000

Emulator.callEndpoint @"create" cid1 cp
_ <- Emulator.waitNSlots 5

let ap = AddParams{apCoinA = ada, apCoinB = coins Map.! "A", apAmountA = 1000, apAmountB = 5000}
Emulator.callEndpoint @"add" cid2 ap
_ <- Emulator.waitNSlots 5
pure ()

-- | Create some sample tokens and distribute them to
-- the emulated wallets
setupTokens :: Contract (Maybe (Semigroup.Last Currency.OneShotCurrency)) Currency.CurrencySchema Currency.CurrencyError ()
setupTokens = do
ownPK <- pubKeyHash <$> ownPubKey
cur <- Currency.forgeContract ownPK [(tn, fromIntegral (length wallets) * amount) | tn <- tokenNames]
let cs = Currency.currencySymbol cur
v = mconcat [Value.singleton cs tn amount | tn <- tokenNames]
forM_ wallets $ \w -> do
let pkh = pubKeyHash $ walletPubKey w
when (pkh /= ownPK) $ do
tx <- submitTx $ mustPayToPubKey pkh v
awaitTxConfirmed $ txId tx
tell $ Just $ Semigroup.Last cur
void $ waitNSlots 10
where
amount = 1000000

wallets :: [Wallet]
wallets = [Wallet i | i <- [1 .. 4]]

tokenNames :: [TokenName]
tokenNames = ["A", "B", "C", "D"]
4 changes: 3 additions & 1 deletion plutus-use-cases/test/Spec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ import qualified Spec.PubKey
import qualified Spec.Rollup
import qualified Spec.Stablecoin
import qualified Spec.TokenAccount
import qualified Spec.Uniswap
import qualified Spec.Vesting
import Test.Tasty
import Test.Tasty.Hedgehog (HedgehogTestLimit (..))
Expand Down Expand Up @@ -52,5 +53,6 @@ tests = localOption limit $ testGroup "use cases" [
Spec.Prism.tests,
Spec.Stablecoin.tests,
Spec.Auction.tests,
Spec.Governance.tests
Spec.Governance.tests,
Spec.Uniswap.tests
]
15 changes: 15 additions & 0 deletions plutus-use-cases/test/Spec/Uniswap.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module Spec.Uniswap(
tests
) where

import Plutus.Contract.Test
import qualified Plutus.Contracts.Uniswap.Trace as Uniswap
import Test.Tasty

tests :: TestTree
tests = testGroup "uniswap" [
checkPredicate "can create a liquidity pool and add liquidity"
assertNoFailedTransactions
Uniswap.uniswapTrace
]

0 comments on commit fdd2ac6

Please sign in to comment.