├── logs.sh ├── status.sh ├── funds.sh ├── pools.sh ├── hie.yaml ├── close.sh ├── remove.sh ├── add.sh ├── swap.sh ├── create.sh ├── .gitignore ├── README.md ├── src ├── Uniswap.hs └── Uniswap │ ├── Pool.hs │ ├── Trace.hs │ ├── Types.hs │ ├── OnChain.hs │ ├── worked.hs │ └── OffChain.hs ├── app ├── Uniswap1.hs ├── uniswap-pab.hs └── uniswap-client.hs ├── uniswap.cabal ├── cabal.project └── LICENSE /logs.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/status" | jq ".cicCurrentState.logs" 3 | -------------------------------------------------------------------------------- /status.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/status" | jq ".cicCurrentState.observableState" 3 | -------------------------------------------------------------------------------- /funds.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/funds" \ 3 | --header 'Content-Type: application/json' \ 4 | --data-raw '[]' 5 | -------------------------------------------------------------------------------- /pools.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/pools" \ 3 | --header 'Content-Type: application/json' \ 4 | --data-raw '[]' 5 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "./app/uniswap-pab.hs" 4 | component: "exe:uniswap-pab" 5 | - path: "./app/uniswap-client.hs" 6 | component: "exe:uniswap-client" 7 | -------------------------------------------------------------------------------- /close.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | 3 | symbol=$( cat symbol.json ) 4 | body="{\"clpCoinB\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$3\"}]},\"clpCoinA\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$2\"}]}}" 5 | echo $body 6 | 7 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/close" \ 8 | --header 'Content-Type: application/json' \ 9 | --data-raw $body 10 | -------------------------------------------------------------------------------- /remove.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | 3 | symbol=$( cat symbol.json ) 4 | body="{\"rpCoinB\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$4\"}]},\"rpDiff\":$2,\"rpCoinA\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$3\"}]}}" 5 | echo $body 6 | 7 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/remove" \ 8 | --header 'Content-Type: application/json' \ 9 | --data-raw $body 10 | -------------------------------------------------------------------------------- /add.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | 3 | symbol=$( cat symbol.json ) 4 | body="{\"apAmountA\":$2,\"apAmountB\":$4,\"apCoinB\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$5\"}]},\"apCoinA\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$3\"}]}}" 5 | echo $body 6 | 7 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/add" \ 8 | --header 'Content-Type: application/json' \ 9 | --data-raw $body 10 | -------------------------------------------------------------------------------- /swap.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | 3 | symbol=$( cat symbol.json ) 4 | body="{\"spAmountA\":$2,\"spAmountB\":0,\"spCoinB\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$4\"}]},\"spCoinA\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$3\"}]}}" 5 | echo $body 6 | 7 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/swap" \ 8 | --header 'Content-Type: application/json' \ 9 | --data-raw $body 10 | -------------------------------------------------------------------------------- /create.sh: -------------------------------------------------------------------------------- 1 | #1/bin/sh 2 | 3 | symbol=$( cat symbol.json ) 4 | body="{\"cpAmountA\":$2,\"cpAmountB\":$4,\"cpCoinB\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$5\"}]},\"cpCoinA\":{\"unAssetClass\":[$symbol,{\"unTokenName\":\"$3\"}]}}" 5 | echo $body 6 | 7 | curl "http://localhost:9080/api/contract/instance/$(cat W$1.cid)/endpoint/create" \ 8 | --header 'Content-Type: application/json' \ 9 | --data-raw $body 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | dist-newstyle/ 25 | symbol.json 26 | *.cid 27 | .DS_Store 28 | **/.DS_Store 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # uniswap-plutus 2 | A complete version of Uniswap V2 router in Plutus. 3 | 4 | 5 | Usecases: 6 | 7 | ```SwapExactTokensForTokens amount ['symbol1', 'symbol2', 'symbol3', ..., 'symboln']``` 8 | 9 | Swaps exactly `amount` number of `symbol1` for `symboln` 10 | 11 | 12 | ```SwapTokensForExactTokens amount ['symbol1', 'symbol2', 'symbol3', ..., 'symboln']``` 13 | 14 | Swaps `symbol1` for exactly `amount` number of `symboln` 15 | -------------------------------------------------------------------------------- /src/Uniswap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | A decentralized exchange for arbitrary token pairs following the 3 | -- [Uniswap protocol](https://uniswap.org/whitepaper.pdf). 4 | -- 5 | -- Details: 6 | -- 7 | -- - 'OffChain' contains the instance endpoints and client functionality 8 | -- - 'OnChain' contains the validation logic 9 | -- - 'Types' conains a few common datatypes for working with this contract 10 | -- - 'Pool' contains functions needed by both on-chain and off-chain code 11 | -- related to working with liquidity pools. 12 | module Uniswap 13 | ( module OnChain 14 | , module OffChain 15 | , module Types 16 | , module Pool 17 | , module Trace 18 | ) where 19 | 20 | import Uniswap.OffChain as OffChain 21 | import Uniswap.OnChain as OnChain 22 | import Uniswap.Pool as Pool 23 | import Uniswap.Trace as Trace 24 | import Uniswap.Types as Types 25 | -------------------------------------------------------------------------------- /app/Uniswap1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE RankNTypes #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | module Uniswap1 where 14 | 15 | import Control.Monad (forM_, when) 16 | import Data.Aeson (FromJSON, ToJSON) 17 | import qualified Data.Semigroup as Semigroup 18 | import Data.Text.Prettyprint.Doc (Pretty (..), viaShow) 19 | import GHC.Generics (Generic) 20 | import Ledger 21 | import Ledger.Constraints 22 | import Ledger.Value as Value 23 | import Plutus.Contract 24 | import qualified Plutus.Contracts.Currency as Currency 25 | import qualified Uniswap as Uniswap 26 | import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin 27 | import Wallet.Emulator.Types (Wallet (..), walletPubKey) 28 | 29 | data UniswapContracts = 30 | Init 31 | | UniswapStart 32 | | UniswapUser Uniswap.Uniswap 33 | deriving (Eq, Ord, Show, Generic) 34 | deriving anyclass (FromJSON, ToJSON) 35 | 36 | instance Pretty UniswapContracts where 37 | pretty = viaShow 38 | 39 | instance Builtin.HasDefinitions UniswapContracts where 40 | getDefinitions = [Init, UniswapStart] 41 | getSchema = \case 42 | UniswapUser _ -> Builtin.endpointsToSchemas @Uniswap.UniswapUserSchema 43 | UniswapStart -> Builtin.endpointsToSchemas @Uniswap.UniswapOwnerSchema 44 | Init -> Builtin.endpointsToSchemas @Empty 45 | getContract = \case 46 | UniswapUser us -> Builtin.SomeBuiltin $ Uniswap.userEndpoints us 47 | UniswapStart -> Builtin.SomeBuiltin Uniswap.ownerEndpoint 48 | Init -> Builtin.SomeBuiltin initContract 49 | 50 | initContract :: Contract (Maybe (Semigroup.Last Currency.OneShotCurrency)) Currency.CurrencySchema Currency.CurrencyError () 51 | initContract = do 52 | ownPK <- pubKeyHash <$> ownPubKey 53 | cur <- Currency.mintContract ownPK [(tn, fromIntegral (length wallets) * amount) | tn <- tokenNames] 54 | let cs = Currency.currencySymbol cur 55 | v = mconcat [Value.singleton cs tn amount | tn <- tokenNames] 56 | forM_ wallets $ \w -> do 57 | let pkh = pubKeyHash $ walletPubKey w 58 | when (pkh /= ownPK) $ do 59 | tx <- submitTx $ mustPayToPubKey pkh v 60 | awaitTxConfirmed $ txId tx 61 | 62 | let pkh = pubKeyHash $ walletPubKey emptyW 63 | tx <- submitTx $ mustPayToPubKey pkh $ Value.singleton cs "A" amount 64 | awaitTxConfirmed $ txId tx 65 | 66 | tell $ Just $ Semigroup.Last cur 67 | where 68 | amount = 1000000 69 | 70 | wallets :: [Wallet] 71 | wallets = [Wallet i | i <- [1 .. 4]] 72 | 73 | emptyW :: Wallet 74 | emptyW = Wallet 5 75 | 76 | tokenNames :: [TokenName] 77 | tokenNames = ["A", "B", "C", "D", "E"] 78 | 79 | cidFile :: Wallet -> FilePath 80 | cidFile w = "W" ++ show (getWallet w) ++ ".cid" 81 | -------------------------------------------------------------------------------- /app/uniswap-pab.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | module Main 12 | ( main 13 | ) where 14 | 15 | import Control.Monad (forM_, void) 16 | import Control.Monad.Freer (interpret) 17 | import Control.Monad.IO.Class (MonadIO (..)) 18 | import Data.Aeson (Result (..), encode, fromJSON) 19 | import qualified Data.ByteString.Lazy as LB 20 | import Data.Default (Default (..)) 21 | import qualified Data.Monoid as Monoid 22 | import qualified Data.Semigroup as Semigroup 23 | import Data.Text (Text) 24 | import qualified Plutus.Contracts.Currency as Currency 25 | import qualified Uniswap as Uniswap 26 | import Plutus.PAB.Effects.Contract.Builtin (Builtin) 27 | import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin 28 | import Plutus.PAB.Simulator (SimulatorEffectHandlers, logString) 29 | import qualified Plutus.PAB.Simulator as Simulator 30 | import qualified Plutus.PAB.Webserver.Server as PAB.Server 31 | import Prelude hiding (init) 32 | import Wallet.Emulator.Types (Wallet (..)) 33 | import Wallet.Types (ContractInstanceId (..)) 34 | 35 | import Data.Aeson (FromJSON, ToJSON) 36 | import Data.Text.Prettyprint.Doc (Pretty (..), viaShow) 37 | import GHC.Generics (Generic) 38 | import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin 39 | 40 | 41 | import Uniswap1 as US 42 | 43 | main :: IO () 44 | main = void $ Simulator.runSimulationWith handlers $ do 45 | shutdown <- PAB.Server.startServerDebug 46 | 47 | cidInit <- Simulator.activateContract (Wallet 1) Init 48 | cs <- flip Simulator.waitForState cidInit $ \json -> case fromJSON json of 49 | Success (Just (Semigroup.Last cur)) -> Just $ Currency.currencySymbol cur 50 | _ -> Nothing 51 | _ <- Simulator.waitUntilFinished cidInit 52 | 53 | liftIO $ LB.writeFile "symbol.json" $ encode cs 54 | logString @(Builtin UniswapContracts) $ "Initialization finished. Minted: " ++ show cs 55 | 56 | cidStart <- Simulator.activateContract (Wallet 1) UniswapStart 57 | us <- flip Simulator.waitForState cidStart $ \json -> case (fromJSON json :: Result (Monoid.Last (Either Text Uniswap.Uniswap))) of 58 | Success (Monoid.Last (Just (Right us))) -> Just us 59 | _ -> Nothing 60 | logString @(Builtin UniswapContracts) $ "Uniswap instance created: " ++ show us 61 | 62 | forM_ (emptyW:wallets) $ \w -> do 63 | cid <- Simulator.activateContract w $ UniswapUser us 64 | liftIO $ writeFile (cidFile w) $ show $ unContractInstanceId cid 65 | logString @(Builtin UniswapContracts) $ "Uniswap user contract started for " ++ show w 66 | 67 | void $ liftIO getLine 68 | 69 | shutdown 70 | 71 | handlers :: SimulatorEffectHandlers (Builtin UniswapContracts) 72 | handlers = 73 | Simulator.mkSimulatorHandlers @(Builtin UniswapContracts) def def 74 | $ interpret 75 | $ Builtin.contractHandler 76 | $ Builtin.handleBuiltin @UniswapContracts 77 | -------------------------------------------------------------------------------- /uniswap.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 2.4 2 | Name: uniswap 3 | Version: 0.1.0.0 4 | Author: Amirhossein Khajehpour, Lars Bruenjes 5 | Maintainer: khajepour.amirhossein@gmail.com, lars.bruenjes@iohk.io 6 | Build-Type: Simple 7 | Copyright: © 2021 Lars Bruenjes 8 | License: Apache-2.0 9 | License-files: LICENSE 10 | 11 | source-repository head 12 | type: git 13 | location: https://github.com/RadNi/uniswap-plutus 14 | 15 | flag defer-plugin-errors 16 | description: 17 | Defer errors from the plugin, useful for things like Haddock that can't handle it. 18 | default: False 19 | manual: True 20 | 21 | common lang 22 | default-language: Haskell2010 23 | default-extensions: ExplicitForAll ScopedTypeVariables 24 | DeriveGeneric StandaloneDeriving DeriveLift 25 | GeneralizedNewtypeDeriving DeriveFunctor DeriveFoldable 26 | DeriveTraversable 27 | ghc-options: -Wall -Wnoncanonical-monad-instances 28 | -Wincomplete-uni-patterns -Wincomplete-record-updates 29 | -Wredundant-constraints -Widentities 30 | -- See Plutus Tx readme 31 | -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas 32 | if flag(defer-plugin-errors) 33 | ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors 34 | 35 | 36 | 37 | library 38 | hs-source-dirs: src 39 | exposed-modules: 40 | Uniswap 41 | Uniswap.OnChain 42 | Uniswap.Pool 43 | Uniswap.OffChain 44 | Uniswap.Types 45 | Uniswap.Trace 46 | 47 | build-depends: 48 | plutus-use-cases -any, 49 | base -any, 50 | aeson -any, 51 | bytestring -any, 52 | containers -any, 53 | data-default -any, 54 | freer-extras -any, 55 | mtl -any, 56 | plutus-core -any, 57 | plutus-tx -any, 58 | plutus-contract -any, 59 | playground-common -any, 60 | plutus-ledger -any, 61 | template-haskell -any, 62 | lens -any, 63 | text -any, 64 | prettyprinter -any, 65 | hashable -any, 66 | freer-simple -any, 67 | streaming -any, 68 | semigroups -any 69 | 70 | if !(impl(ghcjs) || os(ghcjs)) 71 | build-depends: plutus-tx-plugin -any 72 | 73 | if flag(defer-plugin-errors) 74 | ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors 75 | 76 | default-language: Haskell2010 77 | ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise 78 | 79 | 80 | executable uniswap-pab 81 | main-is: uniswap-pab.hs 82 | other-modules: Uniswap1 83 | hs-source-dirs: app 84 | default-language: Haskell2010 85 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat 86 | -Wincomplete-uni-patterns -Wincomplete-record-updates 87 | -Wno-missing-import-lists -Wredundant-constraints -O0 88 | build-depends: 89 | base >=4.9 && <5, 90 | aeson -any, 91 | bytestring -any, 92 | containers -any, 93 | data-default -any, 94 | freer-extras -any, 95 | uniswap -any, 96 | freer-simple -any, 97 | plutus-contract -any, 98 | plutus-ledger -any, 99 | plutus-pab, 100 | plutus-use-cases -any, 101 | prettyprinter -any, 102 | text -any 103 | 104 | executable uniswap-client 105 | main-is: uniswap-client.hs 106 | other-modules: Uniswap1 107 | hs-source-dirs: app 108 | ghc-options: -Wall 109 | build-depends: aeson 110 | , base ^>= 4.14.1.0 111 | , uniswap 112 | , bytestring 113 | , plutus-contract 114 | , plutus-ledger 115 | , plutus-pab 116 | , plutus-use-cases 117 | , prettyprinter 118 | , req ^>= 3.9.0 119 | , text 120 | , uuid 121 | -------------------------------------------------------------------------------- /src/Uniswap/Pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Uniswap.Pool 6 | ( calculateAdditionalLiquidity 7 | , calculateInitialLiquidity 8 | , calculateRemoval 9 | , checkSwap 10 | , lpTicker 11 | ) where 12 | 13 | import Ledger.Value (TokenName (..), unAssetClass, unCurrencySymbol) 14 | import Uniswap.Types 15 | import PlutusTx.Prelude 16 | import PlutusTx.Sqrt 17 | 18 | {-# INLINABLE calculateInitialLiquidity #-} 19 | -- | The initial liquidity is 'ceil( sqrt(x*y) )' where 'x' is the amount of 20 | -- 'Coin A' and y the amount of 'Coin B'. See Eq. 13 of the Uniswap v2 paper. 21 | calculateInitialLiquidity :: Amount A -> Amount B -> Amount Liquidity 22 | calculateInitialLiquidity outA outB = Amount $ case isqrt (unAmount outA * unAmount outB) of 23 | Exactly l 24 | | l > 0 -> l 25 | Approximately l 26 | | l > 0 -> l + 1 27 | _ -> traceError "insufficient liquidity" 28 | 29 | {-# INLINABLE calculateAdditionalLiquidity #-} 30 | calculateAdditionalLiquidity :: Amount A -> Amount B -> Amount Liquidity -> Amount A -> Amount B -> Amount Liquidity 31 | calculateAdditionalLiquidity oldA' oldB' liquidity delA' delB' = 32 | case rsqrt ratio of 33 | Imaginary -> traceError "insufficient liquidity" 34 | Exactly x -> Amount x - liquidity 35 | Approximately x -> Amount x - liquidity 36 | where 37 | ratio = (unAmount (liquidity * liquidity * newProd)) % unAmount oldProd 38 | 39 | -- Unwrap, as we're combining terms 40 | oldA = unAmount oldA' 41 | oldB = unAmount oldB' 42 | delA = unAmount delA' 43 | delB = unAmount delB' 44 | 45 | oldProd, newProd :: Amount Liquidity 46 | oldProd = Amount $ oldA * oldB 47 | newProd = Amount $ (oldA + delA) * (oldB + delB) 48 | 49 | {-# INLINABLE calculateRemoval #-} 50 | -- | See Definition 3 of . 51 | calculateRemoval :: Amount A -> Amount B -> Amount Liquidity -> Amount Liquidity -> (Amount A, Amount B) 52 | calculateRemoval inA inB liquidity' diff' = (f inA, f inB) 53 | where 54 | f :: Amount a -> Amount a 55 | f = Amount . g . unAmount 56 | 57 | diff = unAmount diff' 58 | liquidity = unAmount liquidity' 59 | 60 | g :: Integer -> Integer 61 | g x = x - divide (x * diff) liquidity 62 | 63 | {-# INLINABLE checkSwap #-} 64 | -- | A swap is valid if the fee is computed correctly, and we're swapping some 65 | -- positive amount of A for B. See: Eq (11) (Page 7.) 66 | checkSwap :: Amount A -> Amount B -> Amount A -> Amount B -> Bool 67 | checkSwap oldA' oldB' newA' newB' = 68 | traceIfFalse "expected positive oldA" (oldA > 0) && 69 | traceIfFalse "expected positive oldB" (oldB > 0) && 70 | traceIfFalse "expected positive-newA" (newA > 0) && 71 | traceIfFalse "expected positive-newB" (newB > 0) && 72 | traceIfFalse "expected product to increase" ((((newA * feeDen) - (inA * feeNum)) * ((newB * feeDen) - (inB * feeNum))) 73 | >= (feeDen * feeDen * oldA * oldB)) 74 | where 75 | -- Unwrap; because we are mixing terms. 76 | oldA = unAmount oldA' 77 | oldB = unAmount oldB' 78 | newA = unAmount newA' 79 | newB = unAmount newB' 80 | 81 | inA = max 0 $ newA - oldA 82 | inB = max 0 $ newB - oldB 83 | -- The uniswap fee is 0.3%; here it is multiplied by 1000, so that the 84 | -- on-chain code deals only in integers. 85 | -- See: Eq (11) (Page 7.) 86 | feeNum, feeDen :: Integer 87 | feeNum = 3 88 | feeDen = 1000 89 | 90 | {-# INLINABLE lpTicker #-} 91 | -- | Generate a unique token name for this particular pool; based on the 92 | -- tokens it exchanges. This should be such that looking for a pool exchanging 93 | -- any two tokens always yields a unique name. 94 | lpTicker :: LiquidityPool -> TokenName 95 | lpTicker LiquidityPool{..} = TokenName hash 96 | where 97 | cA@(csA, tokA) = unAssetClass (unCoin lpCoinA) 98 | cB@(csB, tokB) = unAssetClass (unCoin lpCoinB) 99 | ((x1, y1), (x2, y2)) 100 | | cA < cB = ((csA, tokA), (csB, tokB)) 101 | | otherwise = ((csB, tokB), (csA, tokA)) 102 | 103 | h1 = sha2_256 $ unTokenName y1 104 | h2 = sha2_256 $ unTokenName y2 105 | h3 = sha2_256 $ unCurrencySymbol x1 106 | h4 = sha2_256 $ unCurrencySymbol x2 107 | hash = sha2_256 $ h1 <> h2 <> h3 <> h4 108 | -------------------------------------------------------------------------------- /src/Uniswap/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-| Example trace for the uniswap contract 6 | -} 7 | module Uniswap.Trace( 8 | uniswapTrace 9 | -- 10 | , setupTokens 11 | , tokenNames 12 | , wallets 13 | ) where 14 | 15 | import Control.Monad (forM_, when) 16 | import Control.Monad.Freer.Error (throwError) 17 | import qualified Data.Map as Map 18 | import qualified Data.Monoid as Monoid 19 | import qualified Data.Semigroup as Semigroup 20 | import Ledger 21 | import Ledger.Ada (adaSymbol, adaToken) 22 | import Ledger.Constraints 23 | import Ledger.Value as Value 24 | import Plutus.Contract hiding (throwError) 25 | import qualified Plutus.Contracts.Currency as Currency 26 | import Uniswap.OffChain as OffChain 27 | import Uniswap.Types as Types 28 | import Plutus.Trace.Emulator (EmulatorRuntimeError (GenericError), EmulatorTrace) 29 | import qualified Plutus.Trace.Emulator as Emulator 30 | import Wallet.Emulator.Types (Wallet (..), walletPubKey) 31 | 32 | -- | Set up a liquidity pool and call the "add" endpoint 33 | uniswapTrace :: EmulatorTrace () 34 | uniswapTrace = do 35 | cidInit <- Emulator.activateContract (Wallet 1) setupTokens "init" 36 | _ <- Emulator.waitNSlots 5 37 | cs <- Emulator.observableState cidInit >>= \case 38 | Just (Semigroup.Last cur) -> pure (Currency.currencySymbol cur) 39 | _ -> throwError $ GenericError "failed to create currency" 40 | let coins = Map.fromList [(tn, Types.mkCoin cs tn) | tn <- tokenNames] 41 | ada = Types.mkCoin adaSymbol adaToken 42 | 43 | cidStart <- Emulator.activateContract (Wallet 1) ownerEndpoint "start" 44 | _ <- Emulator.waitNSlots 5 45 | us <- Emulator.observableState cidStart >>= \case 46 | Monoid.Last (Just (Right v)) -> pure v 47 | _ -> throwError $ GenericError "initialisation failed" 48 | 49 | cid2 <- Emulator.activateContractWallet (Wallet 2) (awaitPromise $ userEndpoints us) 50 | cid3 <- Emulator.activateContractWallet (Wallet 3) (awaitPromise $ userEndpoints us) 51 | cid4 <- Emulator.activateContractWallet (Wallet 4) (awaitPromise $ userEndpoints us) 52 | cidArb <- Emulator.activateContractWallet arbitrageur (awaitPromise $ userEndpoints us) 53 | _ <- Emulator.waitNSlots 5 54 | 55 | let cpAB = OffChain.CreateParams (coins Map.! "A") (coins Map.! "B") 10000 20000 56 | cpBC = OffChain.CreateParams (coins Map.! "B") (coins Map.! "C") 20000 30000 57 | cpCD = OffChain.CreateParams (coins Map.! "C") (coins Map.! "D") 30000 40000 58 | cpDA = OffChain.CreateParams (coins Map.! "D") (coins Map.! "A") 40000 80000 59 | 60 | Emulator.callEndpoint @"create" cid2 cpAB 61 | _ <- Emulator.waitNSlots 5 62 | Emulator.callEndpoint @"create" cid2 cpBC 63 | _ <- Emulator.waitNSlots 5 64 | Emulator.callEndpoint @"create" cid3 cpCD 65 | _ <- Emulator.waitNSlots 5 66 | Emulator.callEndpoint @"create" cid4 cpDA 67 | _ <- Emulator.waitNSlots 5 68 | 69 | let swp2 = SwapParams2{amount = 3000, path = [coins Map.! "A", coins Map.! "B", coins Map.! "C", coins Map.! "D", coins Map.! "A"]} 70 | Emulator.callEndpoint @"swapTokensForExactTokens" cidArb swp2 71 | 72 | -- let ap = AddParams{apCoinA = ada, apCoinB = coins Map.! "A", apAmountA = 1000, apAmountB = 5000} 73 | -- Emulator.callEndpoint @"add" cid2 ap 74 | _ <- Emulator.waitNSlots 5 75 | pure () 76 | 77 | -- | Create some sample tokens and distribute them to 78 | -- the emulated wallets 79 | setupTokens :: Contract (Maybe (Semigroup.Last Currency.OneShotCurrency)) Currency.CurrencySchema Currency.CurrencyError () 80 | setupTokens = do 81 | ownPK <- pubKeyHash <$> ownPubKey 82 | cur <- Currency.mintContract ownPK [(tn, fromIntegral (length wallets) * amount) | tn <- tokenNames] 83 | let cs = Currency.currencySymbol cur 84 | v = mconcat [Value.singleton cs tn amount | tn <- tokenNames] 85 | 86 | forM_ wallets $ \w -> do 87 | let pkh = pubKeyHash $ walletPubKey w 88 | when (pkh /= ownPK) $ do 89 | tx <- submitTx $ mustPayToPubKey pkh v 90 | awaitTxConfirmed $ txId tx 91 | 92 | tell $ Just $ Semigroup.Last cur 93 | 94 | where 95 | amount = 1000000 96 | 97 | wallets :: [Wallet] 98 | wallets = [Wallet i | i <- [1 .. 4]] 99 | 100 | arbitrageur :: Wallet 101 | arbitrageur = Wallet 5 102 | 103 | tokenNames :: [TokenName] 104 | tokenNames = ["A", "B", "C", "D"] 105 | -------------------------------------------------------------------------------- /src/Uniswap/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# options_ghc -Wno-redundant-constraints #-} 16 | {-# options_ghc -fno-strictness #-} 17 | {-# options_ghc -fno-specialise #-} 18 | 19 | module Uniswap.Types 20 | where 21 | 22 | import Ledger 23 | import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf) 24 | import Playground.Contract (FromJSON, Generic, ToJSON, ToSchema) 25 | import qualified PlutusTx 26 | import PlutusTx.Prelude 27 | import qualified Prelude as Haskell 28 | import Text.Printf (PrintfArg) 29 | 30 | -- | Uniswap coin token 31 | data U = U deriving (Haskell.Show, Haskell.Eq, Generic) 32 | PlutusTx.makeIsDataIndexed ''U [('U, 0)] 33 | PlutusTx.makeLift ''U 34 | 35 | -- | "A"-side coin token 36 | data A = A 37 | PlutusTx.makeIsDataIndexed ''A [('A, 0)] 38 | PlutusTx.makeLift ''A 39 | 40 | -- | "B"-side coin token 41 | data B = B 42 | PlutusTx.makeIsDataIndexed ''B [('B, 0)] 43 | PlutusTx.makeLift ''B 44 | 45 | -- | Pool-state coin token 46 | data PoolState = PoolState 47 | PlutusTx.makeIsDataIndexed ''PoolState [('PoolState, 0)] 48 | PlutusTx.makeLift ''PoolState 49 | 50 | -- | Liquidity-state coin token 51 | data Liquidity = Liquidity 52 | PlutusTx.makeIsDataIndexed ''Liquidity [('Liquidity, 0)] 53 | PlutusTx.makeLift ''Liquidity 54 | 55 | -- | A single 'AssetClass'. Because we use three coins, we use a phantom type to track 56 | -- which one is which. 57 | newtype Coin a = Coin { unCoin :: AssetClass } 58 | deriving stock (Haskell.Show, Generic) 59 | deriving newtype (ToJSON, FromJSON, ToSchema, Eq, Haskell.Eq, Haskell.Ord) 60 | PlutusTx.makeIsDataIndexed ''Coin [('Coin, 0)] 61 | PlutusTx.makeLift ''Coin 62 | 63 | -- | Likewise for 'Integer'; the corresponding amount we have of the 64 | -- particular 'Coin'. 65 | newtype Amount a = Amount { unAmount :: Integer } 66 | deriving stock (Haskell.Show, Generic) 67 | deriving newtype (ToJSON, FromJSON, ToSchema, Eq, Ord, PrintfArg) 68 | deriving newtype (Haskell.Eq, Haskell.Ord, Haskell.Num) 69 | deriving newtype (AdditiveGroup, AdditiveMonoid, AdditiveSemigroup, MultiplicativeSemigroup) 70 | PlutusTx.makeIsDataIndexed ''Amount [('Amount, 0)] 71 | PlutusTx.makeLift ''Amount 72 | 73 | {-# INLINABLE valueOf #-} 74 | valueOf :: Coin a -> Amount a -> Value 75 | valueOf c a = assetClassValue (unCoin c) (unAmount a) 76 | 77 | {-# INLINABLE unitValue #-} 78 | unitValue :: Coin a -> Value 79 | unitValue c = valueOf c 1 80 | 81 | {-# INLINABLE isUnity #-} 82 | isUnity :: Value -> Coin a -> Bool 83 | isUnity v c = amountOf v c == 1 84 | 85 | {-# INLINABLE amountOf #-} 86 | amountOf :: Value -> Coin a -> Amount a 87 | amountOf v = Amount . assetClassValueOf v . unCoin 88 | 89 | {-# INLINABLE mkCoin #-} 90 | mkCoin:: CurrencySymbol -> TokenName -> Coin a 91 | mkCoin c = Coin . assetClass c 92 | 93 | newtype Uniswap = Uniswap 94 | { usCoin :: Coin U 95 | } deriving stock (Haskell.Show, Generic) 96 | deriving anyclass (ToJSON, FromJSON, ToSchema) 97 | deriving newtype (Haskell.Eq, Haskell.Ord) 98 | PlutusTx.makeIsDataIndexed ''Uniswap [('Uniswap, 0)] 99 | PlutusTx.makeLift ''Uniswap 100 | 101 | data LiquidityPool = LiquidityPool 102 | { lpCoinA :: Coin A 103 | , lpCoinB :: Coin B 104 | } 105 | deriving (Haskell.Show, Generic, ToJSON, FromJSON, ToSchema) 106 | PlutusTx.makeIsDataIndexed ''LiquidityPool [('LiquidityPool, 0)] 107 | PlutusTx.makeLift ''LiquidityPool 108 | 109 | instance Eq LiquidityPool where 110 | {-# INLINABLE (==) #-} 111 | x == y = (lpCoinA x == lpCoinA y && lpCoinB x == lpCoinB y) || 112 | -- Make sure the underlying coins aren't equal. 113 | (unCoin (lpCoinA x) == unCoin (lpCoinB y) && unCoin (lpCoinB x) == unCoin (lpCoinA y)) 114 | 115 | data UniswapAction = Create LiquidityPool | Close | Swap | Remove | Add 116 | deriving Haskell.Show 117 | PlutusTx.makeIsDataIndexed ''UniswapAction [ ('Create , 0) 118 | , ('Close, 1) 119 | , ('Swap, 2) 120 | , ('Remove, 3) 121 | , ('Add, 4) 122 | ] 123 | PlutusTx.makeLift ''UniswapAction 124 | 125 | data UniswapDatum = 126 | Factory [LiquidityPool] 127 | | Pool LiquidityPool (Amount Liquidity) 128 | deriving stock (Haskell.Show) 129 | PlutusTx.makeIsDataIndexed ''UniswapDatum [ ('Factory, 0) 130 | , ('Pool, 1) 131 | ] 132 | PlutusTx.makeLift ''UniswapDatum 133 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | index-state: 2021-07-07T00:00:00Z 2 | 3 | packages: ./. 4 | 5 | -- You never, ever, want this. 6 | write-ghc-environment-files: never 7 | 8 | -- Always build tests and benchmarks. 9 | tests: true 10 | benchmarks: true 11 | 12 | source-repository-package 13 | type: git 14 | location: https://github.com/input-output-hk/plutus.git 15 | subdir: 16 | freer-extras 17 | playground-common 18 | plutus-chain-index 19 | plutus-core 20 | plutus-contract 21 | plutus-ledger 22 | plutus-ledger-api 23 | plutus-pab 24 | plutus-tx 25 | plutus-tx-plugin 26 | plutus-use-cases 27 | prettyprinter-configurable 28 | quickcheck-dynamic 29 | word-array 30 | tag: 7b5829f2ac57fcfa25a5969ff602b48641b36ac3 31 | 32 | -- The following sections are copied from the 'plutus' repository cabal.project at the revision 33 | -- given above. 34 | -- This is necessary because the 'plutus' libraries depend on a number of other libraries which are 35 | -- not on Hackage, and so need to be pulled in as `source-repository-package`s themselves. Make sure to 36 | -- re-update this section from the template when you do an upgrade. 37 | 38 | -- This is also needed so evenful-sql-common will build with a 39 | -- newer version of persistent. See stack.yaml for the mirrored 40 | -- configuration. 41 | package eventful-sql-common 42 | ghc-options: -XDerivingStrategies -XStandaloneDeriving -XUndecidableInstances -XDataKinds -XFlexibleInstances -XMultiParamTypeClasses 43 | 44 | allow-newer: 45 | -- Pins to an old version of Template Haskell, unclear if/when it will be updated 46 | size-based:template-haskell 47 | 48 | -- The following two dependencies are needed by plutus. 49 | , eventful-sql-common:persistent 50 | , eventful-sql-common:persistent-template 51 | , ouroboros-consensus-byron:formatting 52 | , beam-core:aeson 53 | , beam-sqlite:aeson 54 | , beam-sqlite:dlist 55 | , beam-migrate:aeson 56 | 57 | constraints: 58 | -- big breaking change here, inline-r doens't have an upper bound 59 | singletons < 3.0 60 | -- breaks eventful even more than it already was 61 | , persistent-template < 2.12 62 | -- bizarre issue: in earlier versions they define their own 'GEq', in newer 63 | -- ones they reuse the one from 'some', but there isn't e.g. a proper version 64 | -- constraint from dependent-sum-template (which is the library we actually use). 65 | , dependent-sum > 0.6.2.0 66 | 67 | -- See the note on nix/pkgs/default.nix:agdaPackages for why this is here. 68 | -- (NOTE this will change to ieee754 in newer versions of nixpkgs). 69 | extra-packages: ieee, filemanip 70 | 71 | -- These packages appear in our dependency tree and are very slow to build. 72 | -- Empirically, turning off optimization shaves off ~50% build time. 73 | -- It also mildly improves recompilation avoidance. 74 | -- For deve work we don't care about performance so much, so this is okay. 75 | package cardano-ledger-alonzo 76 | optimization: False 77 | package ouroboros-consensus-shelley 78 | optimization: False 79 | package ouroboros-consensus-cardano 80 | optimization: False 81 | package cardano-api 82 | optimization: False 83 | 84 | -- Turn off the tests for a while 85 | package plutus-metatheory 86 | tests: False 87 | 88 | -- Drops an instance breaking our code. Should be released to Hackage eventually. 89 | source-repository-package 90 | type: git 91 | location: https://github.com/Quid2/flat.git 92 | tag: 95e5d7488451e43062ca84d5376b3adcc465f1cd 93 | 94 | -- Needs some patches, but upstream seems to be fairly dead (no activity in > 1 year) 95 | source-repository-package 96 | type: git 97 | location: https://github.com/shmish111/purescript-bridge.git 98 | tag: 6a92d7853ea514be8b70bab5e72077bf5a510596 99 | 100 | source-repository-package 101 | type: git 102 | location: https://github.com/shmish111/servant-purescript.git 103 | tag: a76104490499aa72d40c2790d10e9383e0dbde63 104 | 105 | source-repository-package 106 | type: git 107 | location: https://github.com/input-output-hk/cardano-crypto.git 108 | tag: ce8f1934e4b6252084710975bd9bbc0a4648ece4 109 | 110 | source-repository-package 111 | type: git 112 | location: https://github.com/input-output-hk/cardano-base 113 | tag: a715c7f420770b70bbe95ca51d3dec83866cb1bd 114 | subdir: 115 | binary 116 | binary/test 117 | slotting 118 | cardano-crypto-class 119 | cardano-crypto-praos 120 | cardano-crypto-tests 121 | strict-containers 122 | 123 | source-repository-package 124 | type: git 125 | location: https://github.com/input-output-hk/cardano-prelude 126 | tag: fd773f7a58412131512b9f694ab95653ac430852 127 | subdir: 128 | cardano-prelude 129 | cardano-prelude-test 130 | 131 | source-repository-package 132 | type: git 133 | location: https://github.com/input-output-hk/ouroboros-network 134 | tag: e338f2cf8e1078fbda9555dd2b169c6737ef6774 135 | subdir: 136 | monoidal-synchronisation 137 | typed-protocols 138 | typed-protocols-examples 139 | ouroboros-network 140 | ouroboros-network-testing 141 | ouroboros-network-framework 142 | ouroboros-consensus 143 | ouroboros-consensus-byron 144 | ouroboros-consensus-cardano 145 | ouroboros-consensus-shelley 146 | io-sim 147 | io-classes 148 | network-mux 149 | 150 | source-repository-package 151 | type: git 152 | location: https://github.com/input-output-hk/iohk-monitoring-framework 153 | tag: 34abfb7f4f5610cabb45396e0496472446a0b2ca 154 | subdir: 155 | iohk-monitoring 156 | tracer-transformers 157 | contra-tracer 158 | plugins/backend-aggregation 159 | plugins/backend-ekg 160 | plugins/backend-monitoring 161 | plugins/backend-trace-forwarder 162 | plugins/scribe-systemd 163 | 164 | source-repository-package 165 | type: git 166 | location: https://github.com/input-output-hk/cardano-ledger-specs 167 | tag: 09433fe537a4ab57df19e70be309c48d832f6576 168 | subdir: 169 | byron/chain/executable-spec 170 | byron/crypto 171 | byron/crypto/test 172 | byron/ledger/executable-spec 173 | byron/ledger/impl 174 | byron/ledger/impl/test 175 | semantics/executable-spec 176 | semantics/small-steps-test 177 | shelley/chain-and-ledger/dependencies/non-integer 178 | shelley/chain-and-ledger/executable-spec 179 | shelley/chain-and-ledger/shelley-spec-ledger-test 180 | shelley-ma/impl 181 | cardano-ledger-core 182 | alonzo/impl 183 | 184 | -- A lot of plutus dependencies have to be synchronized with the dependencies of 185 | -- cardano-node. If you update cardano-node, please make sure that all dependencies 186 | -- of cardano-node are also updated. 187 | source-repository-package 188 | type: git 189 | location: https://github.com/input-output-hk/cardano-node.git 190 | tag: f72c6272eb58a43cd1d2ef4f4381f3822b3c60c6 191 | subdir: 192 | cardano-api 193 | cardano-node 194 | cardano-cli 195 | cardano-config 196 | 197 | source-repository-package 198 | type: git 199 | location: https://github.com/input-output-hk/Win32-network 200 | tag: 94153b676617f8f33abe8d8182c37377d2784bd1 201 | 202 | source-repository-package 203 | type: git 204 | location: https://github.com/input-output-hk/hedgehog-extras 205 | tag: 8bcd3c9dc22cc44f9fcfe161f4638a384fc7a187 206 | 207 | source-repository-package 208 | type: git 209 | location: https://github.com/input-output-hk/goblins 210 | tag: cde90a2b27f79187ca8310b6549331e59595e7ba 211 | -------------------------------------------------------------------------------- /app/uniswap-client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main 6 | ( main 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Exception 11 | import Control.Monad (forM_, when) 12 | import Control.Monad.IO.Class (MonadIO (..)) 13 | import Data.Aeson (Result (..), ToJSON, decode, encode, fromJSON) 14 | import qualified Data.ByteString.Lazy.Char8 as B8 15 | import qualified Data.ByteString.Lazy as LB 16 | import Data.Monoid (Last (..)) 17 | import Data.Proxy (Proxy (..)) 18 | import Data.String (IsString (..)) 19 | import Data.Text (Text, pack) 20 | import Data.UUID hiding (fromString) 21 | import Ledger.Value (AssetClass (..), CurrencySymbol, Value, flattenValue, TokenName) 22 | import Network.HTTP.Req 23 | import qualified Uniswap as US 24 | import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse (..)) 25 | import Plutus.PAB.Webserver.Types 26 | import System.Environment (getArgs) 27 | import System.Exit (exitFailure) 28 | import Text.Printf (printf) 29 | import Text.Read (readMaybe) 30 | import Wallet.Emulator.Types (Wallet (..)) 31 | 32 | import Uniswap1 (cidFile, UniswapContracts) 33 | 34 | main :: IO () 35 | main = do 36 | w <- Wallet . read . head <$> getArgs 37 | cid <- read <$> readFile (cidFile w) 38 | mcs <- decode <$> LB.readFile "symbol.json" 39 | case mcs of 40 | Nothing -> putStrLn "invalid symbol.json" >> exitFailure 41 | Just cs -> do 42 | putStrLn $ "cid: " ++ show cid 43 | putStrLn $ "symbol: " ++ show (cs :: CurrencySymbol) 44 | go cid cs 45 | where 46 | go :: UUID -> CurrencySymbol -> IO a 47 | go cid cs = do 48 | cmd <- readCommandIO 49 | case cmd of 50 | Funds -> getFunds cid 51 | Pools -> getPools cid 52 | Create amtA tnA amtB tnB -> createPool cid $ toCreateParams cs amtA tnA amtB tnB 53 | Add amtA tnA amtB tnB -> addLiquidity cid $ toAddParams cs amtA tnA amtB tnB 54 | Remove amt tnA tnB -> removeLiquidity cid $ toRemoveParams cs amt tnA tnB 55 | Close tnA tnB -> closePool cid $ toCloseParams cs tnA tnB 56 | Swap amtA tnA tnB -> swap cid $ toSwapParams cs amtA tnA tnB 57 | SwapExactTokensForTokens amt tns -> swapExactTokensForTokens cid $ toSwapParams2 cs amt tns 58 | SwapTokensForExactTokens amt tns -> swapTokensForExactTokens cid $ toSwapParams2 cs amt tns 59 | go cid cs 60 | 61 | data Command = 62 | Funds 63 | | Pools 64 | | Create Integer Char Integer Char 65 | | Add Integer Char Integer Char 66 | | Remove Integer Char Char 67 | | Close Char Char 68 | | Swap Integer Char Char 69 | | SwapExactTokensForTokens Integer [Char] 70 | | SwapTokensForExactTokens Integer [Char] 71 | deriving (Show, Read, Eq, Ord) 72 | 73 | readCommandIO :: IO Command 74 | readCommandIO = do 75 | putStrLn "Enter a command: Funds, Pools, Create amtA tnA amtB tnB, Add amtA tnA amtB tnB, Remove amt tnA tnB, Close tnA tnB, Swap amtA tnA tnB, SwapExactTokensForTokens amtIn [tnA, tnB, .., tnN], SwapTokensForExactTokens amtOut [tnA, tnB, .., tnN]" 76 | s <- getLine 77 | maybe readCommandIO return $ readMaybe s 78 | 79 | toCoin :: CurrencySymbol -> Char -> US.Coin c 80 | toCoin cs tn = US.Coin $ AssetClass (cs, fromString [tn]) 81 | 82 | toCreateParams :: CurrencySymbol -> Integer -> Char -> Integer -> Char -> US.CreateParams 83 | toCreateParams cs amtA tnA amtB tnB = US.CreateParams (toCoin cs tnA) (toCoin cs tnB) (US.Amount amtA) (US.Amount amtB) 84 | 85 | toAddParams :: CurrencySymbol -> Integer -> Char -> Integer -> Char -> US.AddParams 86 | toAddParams cs amtA tnA amtB tnB = US.AddParams (toCoin cs tnA) (toCoin cs tnB) (US.Amount amtA) (US.Amount amtB) 87 | 88 | toRemoveParams :: CurrencySymbol -> Integer -> Char -> Char -> US.RemoveParams 89 | toRemoveParams cs amt tnA tnB = US.RemoveParams (toCoin cs tnA) (toCoin cs tnB) (US.Amount amt) 90 | 91 | toCloseParams :: CurrencySymbol -> Char -> Char -> US.CloseParams 92 | toCloseParams cs tnA tnB = US.CloseParams (toCoin cs tnA) (toCoin cs tnB) 93 | 94 | toSwapParams :: CurrencySymbol -> Integer -> Char -> Char -> US.SwapParams 95 | toSwapParams cs amtA tnA tnB = US.SwapParams (toCoin cs tnA) (toCoin cs tnB) (US.Amount amtA) (US.Amount 0) 96 | 97 | toSwapParams2 :: CurrencySymbol -> Integer -> [Char] -> US.SwapParams2 98 | toSwapParams2 cs amtA ps = US.SwapParams2 (US.Amount amtA) $ map (toCoin cs) ps 99 | 100 | showCoinHeader :: IO () 101 | showCoinHeader = printf "\n currency symbol token name amount\n\n" 102 | 103 | showCoin :: CurrencySymbol -> TokenName -> Integer -> IO () 104 | showCoin cs tn = printf "%64s %66s %15d\n" (show cs) (show tn) 105 | 106 | getFunds :: UUID -> IO () 107 | getFunds cid = do 108 | callEndpoint cid "funds" () 109 | threadDelay 2_000_000 110 | go 111 | where 112 | go = do 113 | e <- getStatus cid 114 | case e of 115 | Right (US.Funds v) -> showFunds v 116 | _ -> go 117 | 118 | showFunds :: Value -> IO () 119 | showFunds v = do 120 | showCoinHeader 121 | forM_ (flattenValue v) $ \(cs, tn, amt) -> showCoin cs tn amt 122 | printf "\n" 123 | 124 | getPools :: UUID -> IO () 125 | getPools cid = do 126 | callEndpoint cid "pools" () 127 | threadDelay 2_000_000 128 | go 129 | where 130 | go = do 131 | e <- getStatus cid 132 | case e of 133 | Right (US.Pools ps) -> showPools ps 134 | _ -> go 135 | 136 | showPools :: [((US.Coin US.A, US.Amount US.A), (US.Coin US.B, US.Amount US.B))] -> IO () 137 | showPools ps = do 138 | forM_ ps $ \((US.Coin (AssetClass (csA, tnA)), amtA), (US.Coin (AssetClass (csB, tnB)), amtB)) -> do 139 | showCoinHeader 140 | showCoin csA tnA (US.unAmount amtA) 141 | showCoin csB tnB (US.unAmount amtB) 142 | 143 | createPool :: UUID -> US.CreateParams -> IO () 144 | createPool cid cp = do 145 | callEndpoint cid "create" cp 146 | threadDelay 2_000_000 147 | go 148 | where 149 | go = do 150 | e <- getStatus cid 151 | case e of 152 | Right US.Created -> putStrLn "created" 153 | Left err' -> putStrLn $ "error: " ++ show err' 154 | _ -> go 155 | 156 | addLiquidity :: UUID -> US.AddParams -> IO () 157 | addLiquidity cid ap = do 158 | callEndpoint cid "add" ap 159 | threadDelay 2_000_000 160 | go 161 | where 162 | go = do 163 | e <- getStatus cid 164 | case e of 165 | Right US.Added -> putStrLn "added" 166 | Left err' -> putStrLn $ "error: " ++ show err' 167 | _ -> go 168 | 169 | removeLiquidity :: UUID -> US.RemoveParams -> IO () 170 | removeLiquidity cid rp = do 171 | callEndpoint cid "remove" rp 172 | threadDelay 2_000_000 173 | go 174 | where 175 | go = do 176 | e <- getStatus cid 177 | case e of 178 | Right US.Removed -> putStrLn "removed" 179 | Left err' -> putStrLn $ "error: " ++ show err' 180 | _ -> go 181 | 182 | closePool :: UUID -> US.CloseParams -> IO () 183 | closePool cid cp = do 184 | callEndpoint cid "close" cp 185 | threadDelay 2_000_000 186 | go 187 | where 188 | go = do 189 | e <- getStatus cid 190 | case e of 191 | Right US.Closed -> putStrLn "closed" 192 | Left err' -> putStrLn $ "error: " ++ show err' 193 | _ -> go 194 | 195 | swap :: UUID -> US.SwapParams -> IO () 196 | swap cid sp = do 197 | callEndpoint cid "swap" sp 198 | threadDelay 2_000_000 199 | go 200 | where 201 | go = do 202 | e <- getStatus cid 203 | case e of 204 | Right US.Swapped -> putStrLn "swapped" 205 | Left err' -> putStrLn $ "error: " ++ show err' 206 | _ -> go 207 | 208 | swapExactTokensForTokens :: UUID -> US.SwapParams2 -> IO () 209 | swapExactTokensForTokens cid sp = do 210 | callEndpoint cid "swapExactTokensForTokens" sp 211 | threadDelay 2_000_000 212 | go 213 | where 214 | go = do 215 | e <- getStatus cid 216 | case e of 217 | Right US.Swapped2 -> putStrLn "swapped2" 218 | Left err' -> putStrLn $ "error: " ++ show err' 219 | 220 | swapTokensForExactTokens :: UUID -> US.SwapParams2 -> IO () 221 | swapTokensForExactTokens cid sp = do 222 | callEndpoint cid "swapTokensForExactTokens" sp 223 | threadDelay 2_000_000 224 | go 225 | where 226 | go = do 227 | e <- getStatus cid 228 | case e of 229 | Right US.Swapped2 -> putStrLn "swapped2" 230 | Left err' -> putStrLn $ "error: " ++ show err' 231 | 232 | getStatus :: UUID -> IO (Either Text US.UserContractState) 233 | getStatus cid = runReq defaultHttpConfig $ do 234 | liftIO $ printf "\nget request to 127.0.1:9080/api/contract/instance/%s/status\n" (show cid) 235 | w <- req 236 | GET 237 | (http "127.0.0.1" /: "api" /: "contract" /: "instance" /: pack (show cid) /: "status") 238 | NoReqBody 239 | (Proxy :: Proxy (JsonResponse (ContractInstanceClientState UniswapContracts))) 240 | (port 9080) 241 | case fromJSON $ observableState $ cicCurrentState $ responseBody w of 242 | Success (Last Nothing) -> liftIO $ threadDelay 1_000_000 >> getStatus cid 243 | Success (Last (Just e)) -> return e 244 | _ -> liftIO $ ioError $ userError "error decoding state" 245 | 246 | callEndpoint :: ToJSON a => UUID -> String -> a -> IO () 247 | callEndpoint cid name a = handle h $ runReq defaultHttpConfig $ do 248 | liftIO $ printf "\npost request to 127.0.1:9080/api/contract/instance/%s/endpoint/%s\n" (show cid) name 249 | liftIO $ printf "request body: %s\n\n" $ B8.unpack $ encode a 250 | v <- req 251 | POST 252 | (http "127.0.0.1" /: "api" /: "contract" /: "instance" /: pack (show cid) /: "endpoint" /: pack name) 253 | (ReqBodyJson a) 254 | (Proxy :: Proxy (JsonResponse ())) 255 | (port 9080) 256 | when (responseStatusCode v /= 200) $ 257 | liftIO $ ioError $ userError $ "error calling endpoint " ++ name 258 | where 259 | h :: HttpException -> IO () 260 | h = ioError . userError . show 261 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /src/Uniswap/OnChain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NoImplicitPrelude #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# options_ghc -fno-strictness #-} 18 | {-# options_ghc -fno-specialise #-} 19 | 20 | module Uniswap.OnChain 21 | ( mkUniswapValidator 22 | , validateLiquidityMinting 23 | ) where 24 | 25 | import Ledger 26 | import Ledger.Constraints.OnChain as Constraints 27 | import Ledger.Constraints.TxConstraints as Constraints 28 | import Ledger.Value (AssetClass (..), symbols) 29 | import Uniswap.Pool (calculateAdditionalLiquidity, calculateInitialLiquidity, 30 | calculateRemoval, checkSwap, lpTicker) 31 | import Uniswap.Types 32 | import qualified PlutusTx 33 | import PlutusTx.Prelude 34 | 35 | {-# INLINABLE findOwnInput' #-} 36 | findOwnInput' :: ScriptContext -> TxInInfo 37 | findOwnInput' ctx = fromMaybe (error ()) (findOwnInput ctx) 38 | 39 | {-# INLINABLE valueWithin #-} 40 | valueWithin :: TxInInfo -> Value 41 | valueWithin = txOutValue . txInInfoResolved 42 | 43 | {-# INLINABLE validateSwap #-} 44 | -- | We check the swap is valid through 'checkSwap', and otherwise just make 45 | -- sure that the pool token is passed through. 46 | validateSwap :: LiquidityPool -> Coin PoolState -> ScriptContext -> Bool 47 | validateSwap LiquidityPool{..} c ctx = 48 | checkSwap oldA oldB newA newB && 49 | traceIfFalse "expected pool state token to be present in input" (isUnity inVal c) && 50 | traceIfFalse "expected pool state token to be present in output" (isUnity outVal c) && 51 | traceIfFalse "did not expect Uniswap minting" noUniswapMinting 52 | where 53 | info :: TxInfo 54 | info = scriptContextTxInfo ctx 55 | 56 | ownInput :: TxInInfo 57 | ownInput = findOwnInput' ctx 58 | 59 | ownOutput :: TxOut 60 | ownOutput = case [ o 61 | | o <- getContinuingOutputs ctx 62 | , txOutDatumHash o == Just (snd $ ownHashes ctx) 63 | ] of 64 | [o] -> o 65 | _ -> traceError "expected exactly one output to the same liquidity pool" 66 | 67 | oldA = amountA inVal 68 | oldB = amountB inVal 69 | newA = amountA outVal 70 | newB = amountB outVal 71 | 72 | amountA v = amountOf v lpCoinA 73 | amountB v = amountOf v lpCoinB 74 | 75 | inVal, outVal :: Value 76 | inVal = valueWithin ownInput 77 | outVal = txOutValue ownOutput 78 | 79 | noUniswapMinting :: Bool 80 | noUniswapMinting = 81 | let 82 | AssetClass (cs, _) = unCoin c 83 | minted = txInfoMint info 84 | in 85 | all (/= cs) $ symbols minted 86 | 87 | {-# INLINABLE validateCreate #-} 88 | -- | Ths validates the creation of a liquidity pool to exchange coins. In order to be 89 | -- valid, 90 | -- 91 | -- 1,2. We need to be dealing with the Uniswap coin, 92 | -- 3. We have to exchanging different coins, 93 | -- 4. The pool can't already exist, 94 | -- 5. The pool needs a single value as output, 95 | -- 6. The liquidity amount needs to be as-determined by 'calculateInitialLiquidity' 96 | -- (i.e. the amount from the Uniswap V2 paper). 97 | -- 7,8. We need to be exchanging more than zero of each kind of coin. 98 | -- 9. It should output a pool with the determined properties 99 | validateCreate :: Uniswap 100 | -> Coin PoolState 101 | -> [LiquidityPool] 102 | -> LiquidityPool 103 | -> ScriptContext 104 | -> Bool 105 | validateCreate Uniswap{..} c lps lp@LiquidityPool{..} ctx = 106 | traceIfFalse "Uniswap coin not present" (isUnity (valueWithin $ findOwnInput' ctx) usCoin) && -- 1. 107 | Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Factory $ lp : lps) $ unitValue usCoin) && -- 2. 108 | (unCoin lpCoinA /= unCoin lpCoinB) && -- 3. 109 | all (/= lp) lps && -- 4. 110 | isUnity minted c && -- 5. 111 | (amountOf minted liquidityCoin' == liquidity) && -- 6. 112 | (outA > 0) && -- 7. 113 | (outB > 0) && -- 8. 114 | Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Pool lp liquidity) $ -- 9. 115 | valueOf lpCoinA outA <> valueOf lpCoinB outB <> unitValue c) 116 | where 117 | poolOutput :: TxOut 118 | poolOutput = case [o | o <- getContinuingOutputs ctx, isUnity (txOutValue o) c] of 119 | [o] -> o 120 | _ -> traceError "expected exactly one pool output" 121 | 122 | outA = amountOf (txOutValue poolOutput) lpCoinA 123 | outB = amountOf (txOutValue poolOutput) lpCoinB 124 | liquidity = calculateInitialLiquidity outA outB 125 | 126 | minted :: Value 127 | minted = txInfoMint $ scriptContextTxInfo ctx 128 | 129 | liquidityCoin' :: Coin Liquidity 130 | liquidityCoin' = let AssetClass (cs,_) = unCoin c in mkCoin cs $ lpTicker lp 131 | 132 | {-# INLINABLE validateCloseFactory #-} 133 | -- | See 'Plutus.Contracts.Uniswap.OffChain.close'. 134 | validateCloseFactory :: Uniswap -> Coin PoolState -> [LiquidityPool] -> ScriptContext -> Bool 135 | validateCloseFactory Uniswap{..} c lps ctx = 136 | traceIfFalse "Uniswap coin not present" (isUnity (valueWithin $ findOwnInput' ctx) usCoin) && -- 1. 137 | traceIfFalse "wrong mint value" (txInfoMint info == negate (unitValue c <> valueOf lC (snd lpLiquidity))) && -- 2. 138 | traceIfFalse "factory output wrong" -- 3. 139 | (Constraints.checkOwnOutputConstraint ctx $ OutputConstraint (Factory $ filter (/= fst lpLiquidity) lps) $ unitValue usCoin) 140 | where 141 | info :: TxInfo 142 | info = scriptContextTxInfo ctx 143 | 144 | poolInput :: TxInInfo 145 | poolInput = case [ i 146 | | i <- txInfoInputs info 147 | , isUnity (valueWithin i) c 148 | ] of 149 | [i] -> i 150 | _ -> traceError "expected exactly one pool input" 151 | 152 | lpLiquidity :: (LiquidityPool, Amount Liquidity) 153 | lpLiquidity = case txOutDatumHash . txInInfoResolved $ poolInput of 154 | Nothing -> traceError "pool input witness missing" 155 | Just h -> findPoolDatum info h 156 | 157 | lC :: Coin Liquidity 158 | lC = let AssetClass (cs, _) = unCoin c in mkCoin cs (lpTicker $ fst lpLiquidity) 159 | 160 | {-# INLINABLE validateClosePool #-} 161 | -- | See 'Plutus.Contracts.Uniswap.OffChain.close'. 162 | validateClosePool :: Uniswap -> ScriptContext -> Bool 163 | validateClosePool us ctx = hasFactoryInput 164 | where 165 | info :: TxInfo 166 | info = scriptContextTxInfo ctx 167 | 168 | hasFactoryInput :: Bool 169 | hasFactoryInput = 170 | traceIfFalse "Uniswap factory input expected" $ 171 | isUnity (valueSpent info) (usCoin us) 172 | 173 | {-# INLINABLE validateRemove #-} 174 | -- | See 'Plutus.Contracts.Uniswap.OffChain.remove'. 175 | validateRemove :: Coin PoolState -> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool 176 | validateRemove c lp liquidity ctx = 177 | traceIfFalse "zero removal" (diff > 0) && 178 | traceIfFalse "removal of too much liquidity" (diff < liquidity) && 179 | traceIfFalse "pool state coin missing" (isUnity inVal c) && 180 | traceIfFalse "wrong liquidity pool output" (fst lpLiquidity == lp) && 181 | traceIfFalse "pool state coin missing from output" (isUnity outVal c) && 182 | traceIfFalse "liquidity tokens not burnt" (txInfoMint info == negate (valueOf lC diff)) && 183 | traceIfFalse "non-positive liquidity" (outA > 0 && outB > 0) 184 | where 185 | info :: TxInfo 186 | info = scriptContextTxInfo ctx 187 | 188 | ownInput :: TxInInfo 189 | ownInput = findOwnInput' ctx 190 | 191 | output :: TxOut 192 | output = case getContinuingOutputs ctx of 193 | [o] -> o 194 | _ -> traceError "expected exactly one Uniswap output" 195 | 196 | inVal, outVal :: Value 197 | inVal = valueWithin ownInput 198 | outVal = txOutValue output 199 | 200 | lpLiquidity :: (LiquidityPool, Amount Liquidity) 201 | lpLiquidity = case txOutDatumHash output of 202 | Nothing -> traceError "pool output witness missing" 203 | Just h -> findPoolDatum info h 204 | 205 | lC :: Coin Liquidity 206 | lC = let AssetClass (cs, _) = unCoin c in mkCoin cs (lpTicker lp) 207 | 208 | diff = liquidity - snd lpLiquidity 209 | inA = amountOf inVal $ lpCoinA lp 210 | inB = amountOf inVal $ lpCoinB lp 211 | (outA, outB) = calculateRemoval inA inB liquidity diff 212 | 213 | {-# INLINABLE validateAdd #-} 214 | -- | See 'Plutus.Contracts.Uniswap.OffChain.add'. 215 | validateAdd :: Coin PoolState -> LiquidityPool -> Amount Liquidity -> ScriptContext -> Bool 216 | validateAdd c lp liquidity ctx = 217 | traceIfFalse "pool stake token missing from input" (isUnity inVal c) && 218 | traceIfFalse "output pool for same liquidity pair expected" (lp == fst outDatum) && 219 | traceIfFalse "must not remove tokens" (delA >= 0 && delB >= 0) && 220 | traceIfFalse "insufficient liquidity" (delL >= 0) && 221 | traceIfFalse "wrong amount of liquidity tokens" (delL == calculateAdditionalLiquidity oldA oldB liquidity delA delB) && 222 | traceIfFalse "wrong amount of liquidity tokens minted" (txInfoMint info == valueOf lC delL) 223 | where 224 | info :: TxInfo 225 | info = scriptContextTxInfo ctx 226 | 227 | ownInput :: TxInInfo 228 | ownInput = findOwnInput' ctx 229 | 230 | ownOutput :: TxOut 231 | ownOutput = case [ o 232 | | o <- getContinuingOutputs ctx 233 | , isUnity (txOutValue o) c 234 | ] of 235 | [o] -> o 236 | _ -> traceError "expected exactly on pool output" 237 | 238 | outDatum :: (LiquidityPool, Amount Liquidity) 239 | outDatum = case txOutDatum ownOutput of 240 | Nothing -> traceError "pool output datum hash not found" 241 | Just h -> findPoolDatum info h 242 | 243 | inVal, outVal :: Value 244 | inVal = valueWithin ownInput 245 | outVal = txOutValue ownOutput 246 | 247 | oldA = amountOf inVal aC 248 | oldB = amountOf inVal bC 249 | delA = amountOf outVal aC - oldA 250 | delB = amountOf outVal bC - oldB 251 | delL = snd outDatum - liquidity 252 | 253 | aC = lpCoinA lp 254 | bC = lpCoinB lp 255 | 256 | lC :: Coin Liquidity 257 | lC = let AssetClass (cs, _) = unCoin c in mkCoin cs $ lpTicker lp 258 | 259 | {-# INLINABLE findPoolDatum #-} 260 | findPoolDatum :: TxInfo -> DatumHash -> (LiquidityPool, Amount Liquidity) 261 | findPoolDatum info h = case findDatum h info of 262 | Just (Datum d) -> case PlutusTx.unsafeFromBuiltinData d of 263 | (Pool lp a) -> (lp, a) 264 | _ -> traceError "error decoding data" 265 | _ -> traceError "pool input datum not found" 266 | 267 | {-# INLINABLE mkUniswapValidator #-} 268 | mkUniswapValidator :: Uniswap 269 | -> Coin PoolState 270 | -> UniswapDatum 271 | -> UniswapAction 272 | -> ScriptContext 273 | -> Bool 274 | mkUniswapValidator us c (Factory lps) (Create lp) ctx = validateCreate us c lps lp ctx 275 | mkUniswapValidator _ c (Pool lp _) Swap ctx = validateSwap lp c ctx 276 | mkUniswapValidator us c (Factory lps) Close ctx = validateCloseFactory us c lps ctx 277 | mkUniswapValidator us _ (Pool _ _) Close ctx = validateClosePool us ctx 278 | mkUniswapValidator _ c (Pool lp a) Remove ctx = validateRemove c lp a ctx 279 | mkUniswapValidator _ c (Pool lp a) Add ctx = validateAdd c lp a ctx 280 | mkUniswapValidator _ _ _ _ _ = False 281 | 282 | {-# INLINABLE validateLiquidityMinting #-} 283 | validateLiquidityMinting :: Uniswap -> TokenName -> () -> ScriptContext -> Bool 284 | validateLiquidityMinting Uniswap{..} tn _ ctx 285 | = case [ i 286 | | i <- txInfoInputs $ scriptContextTxInfo ctx 287 | , let v = valueWithin i 288 | , isUnity v usCoin || isUnity v lpC 289 | ] of 290 | [_] -> True 291 | [_, _] -> True 292 | _ -> traceError "pool state minting without Uniswap input" 293 | where 294 | lpC :: Coin Liquidity 295 | lpC = mkCoin (ownCurrencySymbol ctx) tn 296 | -------------------------------------------------------------------------------- /src/Uniswap/worked.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NoImplicitPrelude #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | 18 | module Uniswap.OffChain 19 | ( poolStateCoinFromUniswapCurrency, liquidityCoin 20 | , CreateParams (..) 21 | , SwapParams (..) 22 | , SwapParams2 (..) 23 | , CloseParams (..) 24 | , RemoveParams (..) 25 | , AddParams (..) 26 | , UniswapUserSchema, UserContractState (..) 27 | , UniswapOwnerSchema 28 | , start, create, add, remove, close, swap, pools 29 | , ownerEndpoint, userEndpoints 30 | ) where 31 | 32 | import Control.Monad hiding (fmap) 33 | import qualified Data.Map as Map 34 | import Data.Monoid (Last (..)) 35 | import Data.Proxy (Proxy (..)) 36 | import Data.Text (Text, pack) 37 | import Data.Void (Void, absurd) 38 | import Ledger hiding (singleton) 39 | import Ledger.Constraints as Constraints 40 | import qualified Ledger.Typed.Scripts as Scripts 41 | import Playground.Contract 42 | import Plutus.Contract 43 | import qualified Plutus.Contracts.Currency as Currency 44 | import Uniswap.OnChain (mkUniswapValidator, validateLiquidityMinting) 45 | import Uniswap.Pool 46 | import Uniswap.Types 47 | import qualified PlutusTx 48 | import PlutusTx.Prelude hiding (Semigroup (..), dropWhile, flip, unless) 49 | import Prelude as Haskell (Int, Semigroup (..), String, div, dropWhile, flip, show, 50 | (^)) 51 | import Text.Printf (printf) 52 | 53 | data Uniswapping 54 | instance Scripts.ValidatorTypes Uniswapping where 55 | type instance RedeemerType Uniswapping = UniswapAction 56 | type instance DatumType Uniswapping = UniswapDatum 57 | 58 | type UniswapOwnerSchema = Endpoint "start" () 59 | 60 | -- | Schema for the endpoints for users of Uniswap. 61 | type UniswapUserSchema = 62 | Endpoint "create" CreateParams 63 | .\/ Endpoint "swap" SwapParams 64 | .\/ Endpoint "swap2" SwapParams2 65 | .\/ Endpoint "close" CloseParams 66 | .\/ Endpoint "remove" RemoveParams 67 | .\/ Endpoint "add" AddParams 68 | .\/ Endpoint "pools" () 69 | .\/ Endpoint "funds" () 70 | .\/ Endpoint "stop" () 71 | 72 | -- | Type of the Uniswap user contract state. 73 | data UserContractState = 74 | Pools [((Coin A, Amount A), (Coin B, Amount B))] 75 | | Funds Value 76 | | Created 77 | | Swapped 78 | | Swapped2 79 | | Added 80 | | Removed 81 | | Closed 82 | | Stopped 83 | deriving (Show, Generic, FromJSON, ToJSON) 84 | 85 | 86 | uniswapTokenName, poolStateTokenName :: TokenName 87 | uniswapTokenName = "Uniswap" 88 | poolStateTokenName = "Pool State" 89 | 90 | uniswapInstance :: Uniswap -> Scripts.TypedValidator Uniswapping 91 | uniswapInstance us = Scripts.mkTypedValidator @Uniswapping 92 | ($$(PlutusTx.compile [|| mkUniswapValidator ||]) 93 | `PlutusTx.applyCode` PlutusTx.liftCode us 94 | `PlutusTx.applyCode` PlutusTx.liftCode c) 95 | $$(PlutusTx.compile [|| wrap ||]) 96 | where 97 | c :: Coin PoolState 98 | c = poolStateCoin us 99 | 100 | wrap = Scripts.wrapValidator @UniswapDatum @UniswapAction 101 | 102 | uniswapScript :: Uniswap -> Validator 103 | uniswapScript = Scripts.validatorScript . uniswapInstance 104 | 105 | uniswapAddress :: Uniswap -> Ledger.Address 106 | uniswapAddress = Ledger.scriptAddress . uniswapScript 107 | 108 | uniswap :: CurrencySymbol -> Uniswap 109 | uniswap cs = Uniswap $ mkCoin cs uniswapTokenName 110 | 111 | liquidityPolicy :: Uniswap -> MintingPolicy 112 | liquidityPolicy us = mkMintingPolicyScript $ 113 | $$(PlutusTx.compile [|| \u t -> Scripts.wrapMintingPolicy (validateLiquidityMinting u t) ||]) 114 | `PlutusTx.applyCode` PlutusTx.liftCode us 115 | `PlutusTx.applyCode` PlutusTx.liftCode poolStateTokenName 116 | 117 | liquidityCurrency :: Uniswap -> CurrencySymbol 118 | liquidityCurrency = scriptCurrencySymbol . liquidityPolicy 119 | 120 | poolStateCoin :: Uniswap -> Coin PoolState 121 | poolStateCoin = flip mkCoin poolStateTokenName . liquidityCurrency 122 | 123 | -- | Gets the 'Coin' used to identity liquidity pools. 124 | poolStateCoinFromUniswapCurrency :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. 125 | -> Coin PoolState 126 | poolStateCoinFromUniswapCurrency = poolStateCoin . uniswap 127 | 128 | -- | Gets the liquidity token for a given liquidity pool. 129 | liquidityCoin :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. 130 | -> Coin A -- ^ One coin in the liquidity pair. 131 | -> Coin B -- ^ The other coin in the liquidity pair. 132 | -> Coin Liquidity 133 | liquidityCoin cs coinA coinB = mkCoin (liquidityCurrency $ uniswap cs) $ lpTicker $ LiquidityPool coinA coinB 134 | 135 | -- | Parameters for the @create@-endpoint, which creates a new liquidity pool. 136 | data CreateParams = CreateParams 137 | { cpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 138 | , cpCoinB :: Coin B -- ^ The other 'Coin'. 139 | , cpAmountA :: Amount A -- ^ Amount of liquidity for the first 'Coin'. 140 | , cpAmountB :: Amount B -- ^ Amount of liquidity for the second 'Coin'. 141 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 142 | 143 | -- | Parameters for the @swap@-endpoint, which allows swaps between the two different coins in a liquidity pool. 144 | -- One of the provided amounts must be positive, the other must be zero. 145 | data SwapParams = SwapParams 146 | { spCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 147 | , spCoinB :: Coin B -- ^ The other 'Coin'. 148 | , spAmountA :: Amount A -- ^ The amount the first 'Coin' that should be swapped. 149 | , spAmountB :: Amount B -- ^ The amount of the second 'Coin' that should be swapped. 150 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 151 | 152 | data SwapParams2 = SwapParams2 153 | { 154 | path :: [(Coin A, Amount A)] 155 | -- spCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 156 | -- , spCoinB :: Coin B -- ^ The other 'Coin'. 157 | -- , spAmountA :: Amount A -- ^ The amount the first 'Coin' that should be swapped. 158 | -- , spAmountB :: Amount B -- ^ The amount of the second 'Coin' that should be swapped. 159 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 160 | 161 | -- | Parameters for the @close@-endpoint, which closes a liquidity pool. 162 | data CloseParams = CloseParams 163 | { clpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 164 | , clpCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 165 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 166 | 167 | -- | Parameters for the @remove@-endpoint, which removes some liquidity from a liquidity pool. 168 | data RemoveParams = RemoveParams 169 | { rpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 170 | , rpCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 171 | , rpDiff :: Amount Liquidity -- ^ The amount of liquidity tokens to burn in exchange for liquidity from the pool. 172 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 173 | 174 | -- | Parameters for the @add@-endpoint, which adds liquidity to a liquidity pool in exchange for liquidity tokens. 175 | data AddParams = AddParams 176 | { apCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 177 | , apCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 178 | , apAmountA :: Amount A -- ^ The amount of coins of the first kind to add to the pool. 179 | , apAmountB :: Amount B -- ^ The amount of coins of the second kind to add to the pool. 180 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 181 | 182 | -- | Creates a Uniswap "factory". This factory will keep track of the existing liquidity pools and enforce that there will be at most one liquidity pool 183 | -- for any pair of tokens at any given time. 184 | start :: forall w s. Contract w s Text Uniswap 185 | start = do 186 | pkh <- pubKeyHash <$> ownPubKey 187 | cs <- fmap Currency.currencySymbol $ 188 | mapError (pack . show @Currency.CurrencyError) $ 189 | Currency.mintContract pkh [(uniswapTokenName, 1)] 190 | let c = mkCoin cs uniswapTokenName 191 | us = uniswap cs 192 | inst = uniswapInstance us 193 | tx = mustPayToTheScript (Factory []) $ unitValue c 194 | ledgerTx <- submitTxConstraints inst tx 195 | void $ awaitTxConfirmed $ txId ledgerTx 196 | void $ waitNSlots 1 197 | 198 | logInfo @String $ printf "started Uniswap %s at address %s" (show us) (show $ uniswapAddress us) 199 | return us 200 | 201 | -- | Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. 202 | create :: forall w s. Uniswap -> CreateParams -> Contract w s Text () 203 | create us CreateParams{..} = do 204 | when (unCoin cpCoinA == unCoin cpCoinB) $ throwError "coins must be different" 205 | when (cpAmountA <= 0 || cpAmountB <= 0) $ throwError "amounts must be positive" 206 | (oref, o, lps) <- findUniswapFactory us 207 | let liquidity = calculateInitialLiquidity cpAmountA cpAmountB 208 | lp = LiquidityPool {lpCoinA = cpCoinA, lpCoinB = cpCoinB} 209 | let usInst = uniswapInstance us 210 | usScript = uniswapScript us 211 | usDat1 = Factory $ lp : lps 212 | usDat2 = Pool lp liquidity 213 | psC = poolStateCoin us 214 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 215 | usVal = unitValue $ usCoin us 216 | lpVal = valueOf cpCoinA cpAmountA <> valueOf cpCoinB cpAmountB <> unitValue psC 217 | 218 | lookups = Constraints.typedValidatorLookups usInst <> 219 | Constraints.otherScript usScript <> 220 | Constraints.mintingPolicy (liquidityPolicy us) <> 221 | Constraints.unspentOutputs (Map.singleton oref o) 222 | 223 | tx = Constraints.mustPayToTheScript usDat1 usVal <> 224 | Constraints.mustPayToTheScript usDat2 lpVal <> 225 | Constraints.mustMintValue (unitValue psC <> valueOf lC liquidity) <> 226 | Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData $ Create lp) 227 | 228 | ledgerTx <- submitTxConstraintsWith lookups tx 229 | void $ awaitTxConfirmed $ txId ledgerTx 230 | 231 | logInfo $ "created liquidity pool: " ++ show lp 232 | 233 | -- | Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. 234 | close :: forall w s. Uniswap -> CloseParams -> Contract w s Text () 235 | close us CloseParams{..} = do 236 | ((oref1, o1, lps), (oref2, o2, lp, liquidity)) <- findUniswapFactoryAndPool us clpCoinA clpCoinB 237 | pkh <- pubKeyHash <$> ownPubKey 238 | let usInst = uniswapInstance us 239 | usScript = uniswapScript us 240 | usDat = Factory $ filter (/= lp) lps 241 | usC = usCoin us 242 | psC = poolStateCoin us 243 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 244 | usVal = unitValue usC 245 | psVal = unitValue psC 246 | lVal = valueOf lC liquidity 247 | redeemer = Redeemer $ PlutusTx.toBuiltinData Close 248 | 249 | lookups = Constraints.typedValidatorLookups usInst <> 250 | Constraints.otherScript usScript <> 251 | Constraints.mintingPolicy (liquidityPolicy us) <> 252 | Constraints.ownPubKeyHash pkh <> 253 | Constraints.unspentOutputs (Map.singleton oref1 o1 <> Map.singleton oref2 o2) 254 | 255 | tx = Constraints.mustPayToTheScript usDat usVal <> 256 | Constraints.mustMintValue (negate $ psVal <> lVal) <> 257 | Constraints.mustSpendScriptOutput oref1 redeemer <> 258 | Constraints.mustSpendScriptOutput oref2 redeemer <> 259 | Constraints.mustIncludeDatum (Datum $ PlutusTx.toBuiltinData $ Pool lp liquidity) 260 | 261 | ledgerTx <- submitTxConstraintsWith lookups tx 262 | void $ awaitTxConfirmed $ txId ledgerTx 263 | 264 | logInfo $ "closed liquidity pool: " ++ show lp 265 | 266 | -- | Removes some liquidity from a liquidity pool in exchange for liquidity tokens. 267 | remove :: forall w s. Uniswap -> RemoveParams -> Contract w s Text () 268 | remove us RemoveParams{..} = do 269 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us rpCoinA rpCoinB 270 | pkh <- pubKeyHash <$> ownPubKey 271 | when (rpDiff < 1 || rpDiff >= liquidity) $ throwError "removed liquidity must be positive and less than total liquidity" 272 | let usInst = uniswapInstance us 273 | usScript = uniswapScript us 274 | dat = Pool lp $ liquidity - rpDiff 275 | psC = poolStateCoin us 276 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 277 | psVal = unitValue psC 278 | lVal = valueOf lC rpDiff 279 | inVal = txOutValue $ txOutTxOut o 280 | inA = amountOf inVal rpCoinA 281 | inB = amountOf inVal rpCoinB 282 | (outA, outB) = calculateRemoval inA inB liquidity rpDiff 283 | val = psVal <> valueOf rpCoinA outA <> valueOf rpCoinB outB 284 | redeemer = Redeemer $ PlutusTx.toBuiltinData Remove 285 | 286 | lookups = Constraints.typedValidatorLookups usInst <> 287 | Constraints.otherScript usScript <> 288 | Constraints.mintingPolicy (liquidityPolicy us) <> 289 | Constraints.unspentOutputs (Map.singleton oref o) <> 290 | Constraints.ownPubKeyHash pkh 291 | 292 | tx = Constraints.mustPayToTheScript dat val <> 293 | Constraints.mustMintValue (negate lVal) <> 294 | Constraints.mustSpendScriptOutput oref redeemer 295 | 296 | ledgerTx <- submitTxConstraintsWith lookups tx 297 | void $ awaitTxConfirmed $ txId ledgerTx 298 | 299 | logInfo $ "removed liquidity from pool: " ++ show lp 300 | 301 | -- | Adds some liquidity to an existing liquidity pool in exchange for newly minted liquidity tokens. 302 | add :: forall w s. Uniswap -> AddParams -> Contract w s Text () 303 | add us AddParams{..} = do 304 | pkh <- pubKeyHash <$> ownPubKey 305 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us apCoinA apCoinB 306 | when (apAmountA < 0 || apAmountB < 0) $ throwError "amounts must not be negative" 307 | let outVal = txOutValue $ txOutTxOut o 308 | oldA = amountOf outVal apCoinA 309 | oldB = amountOf outVal apCoinB 310 | newA = oldA + apAmountA 311 | newB = oldB + apAmountB 312 | delL = calculateAdditionalLiquidity oldA oldB liquidity apAmountA apAmountB 313 | inVal = valueOf apCoinA apAmountA <> valueOf apCoinB apAmountB 314 | when (delL <= 0) $ throwError "insufficient liquidity" 315 | logInfo @String $ printf "oldA = %d, oldB = %d, newA = %d, newB = %d, delL = %d" oldA oldB newA newB delL 316 | 317 | let usInst = uniswapInstance us 318 | usScript = uniswapScript us 319 | dat = Pool lp $ liquidity + delL 320 | psC = poolStateCoin us 321 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 322 | psVal = unitValue psC 323 | lVal = valueOf lC delL 324 | val = psVal <> valueOf apCoinA newA <> valueOf apCoinB newB 325 | redeemer = Redeemer $ PlutusTx.toBuiltinData Add 326 | 327 | lookups = Constraints.typedValidatorLookups usInst <> 328 | Constraints.otherScript usScript <> 329 | Constraints.mintingPolicy (liquidityPolicy us) <> 330 | Constraints.ownPubKeyHash pkh <> 331 | Constraints.unspentOutputs (Map.singleton oref o) 332 | 333 | tx = Constraints.mustPayToTheScript dat val <> 334 | Constraints.mustMintValue lVal <> 335 | Constraints.mustSpendScriptOutput oref redeemer 336 | 337 | logInfo @String $ printf "val = %s, inVal = %s" (show val) (show inVal) 338 | logInfo $ show lookups 339 | logInfo $ show tx 340 | 341 | ledgerTx <- submitTxConstraintsWith lookups tx 342 | void $ awaitTxConfirmed $ txId ledgerTx 343 | 344 | logInfo $ "added liquidity to pool: " ++ show lp 345 | 346 | -- | Uses a liquidity pool two swap one sort of coins in the pool against the other. 347 | swap :: forall w s. Uniswap -> SwapParams -> Contract w s Text () 348 | swap us SwapParams{..} = do 349 | unless (spAmountA > 0 && spAmountB == 0 || spAmountA == 0 && spAmountB > 0) $ throwError "exactly one amount must be positive" 350 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us spCoinA spCoinB 351 | let outVal = txOutValue $ txOutTxOut o 352 | let oldA = amountOf outVal spCoinA 353 | oldB = amountOf outVal spCoinB 354 | (newA, newB) <- if spAmountA > 0 then do 355 | let outB = Amount $ findSwapA oldA oldB spAmountA 356 | when (outB == 0) $ throwError "no payout" 357 | return (oldA + spAmountA, oldB - outB) 358 | else do 359 | let outA = Amount $ findSwapB oldA oldB spAmountB 360 | when (outA == 0) $ throwError "no payout" 361 | return (oldA - outA, oldB + spAmountB) 362 | pkh <- pubKeyHash <$> ownPubKey 363 | 364 | logInfo @String $ printf "oldA = %d, oldB = %d, old product = %d, newA = %d, newB = %d, new product = %d" oldA oldB (unAmount oldA * unAmount oldB) newA newB (unAmount newA * unAmount newB) 365 | 366 | let inst = uniswapInstance us 367 | val = valueOf spCoinA newA <> valueOf spCoinB newB <> unitValue (poolStateCoin us) 368 | 369 | lookups = Constraints.typedValidatorLookups inst <> 370 | Constraints.otherScript (Scripts.validatorScript inst) <> 371 | Constraints.unspentOutputs (Map.singleton oref o) <> 372 | Constraints.ownPubKeyHash pkh 373 | 374 | tx = mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 375 | Constraints.mustPayToTheScript (Pool lp liquidity) val 376 | 377 | logInfo $ show tx 378 | ledgerTx <- submitTxConstraintsWith lookups tx 379 | logInfo $ show ledgerTx 380 | void $ awaitTxConfirmed $ txId ledgerTx 381 | logInfo $ "swapped with: " ++ show lp 382 | 383 | 384 | swap2 :: forall w s. Uniswap -> SwapParams2 -> Contract w s Text () 385 | swap2 us SwapParams2{..} = do 386 | -- (oref1, o1, lps) <- findUniswapFactory us 387 | (tx, lookups) <- case path of 388 | [(cA, amntA), (cB, amntB), (cC, amntC)] -> do 389 | unless (amntA > 0 && amntB == 0 && amntC == 0) $ throwError "only first amount must be positive" 390 | -- (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us spCoinA spCoinB 391 | (lp1oref, lp1o, lp1a) <- findUniswapPool us LiquidityPool{lpCoinA=cA, lpCoinB= Coin $ unCoin cB} 392 | (lp2oref, lp2o, lp2a) <- findUniswapPool us LiquidityPool{lpCoinA=cB, lpCoinB= Coin $ unCoin cC} 393 | pkh <- pubKeyHash <$> ownPubKey 394 | 395 | let inst = uniswapInstance us 396 | 397 | lp1outVal = txOutValue $ txOutTxOut lp1o 398 | lp1oldA = amountOf lp1outVal cA 399 | lp1oldB = amountOf lp1outVal $ Coin $ unCoin cB 400 | lp2outVal = txOutValue $ txOutTxOut lp2o 401 | lp2oldB = amountOf lp2outVal cB 402 | lp2oldC = amountOf lp2outVal $ Coin $ unCoin cC 403 | lp1outB = Amount $ findSwapA lp1oldA lp1oldB amntA 404 | lp2outC = Amount $ findSwapA lp2oldB lp2oldC lp1outB 405 | (lp1newA, lp1newB) = (lp1oldA + amntA, lp1oldB - (Amount $ unAmount lp1outB)) 406 | (lp2newB, lp2newC) = (lp2oldB + lp1outB, lp2oldC - lp2outC) 407 | 408 | val1 = valueOf cA lp1newA <> valueOf cB (Amount $ unAmount lp1newB) <> unitValue (poolStateCoin us) 409 | val2 = valueOf cB lp2newB <> valueOf cC (Amount $ unAmount lp2newC) <> unitValue (poolStateCoin us) 410 | 411 | lookups = Constraints.typedValidatorLookups inst <> 412 | Constraints.otherScript (Scripts.validatorScript inst) <> 413 | Constraints.unspentOutputs (Map.singleton lp1oref lp1o) <> 414 | Constraints.unspentOutputs (Map.singleton lp2oref lp2o) <> 415 | Constraints.ownPubKeyHash pkh 416 | 417 | tx = Constraints.mustSpendScriptOutput lp1oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 418 | Constraints.mustSpendScriptOutput lp2oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 419 | Constraints.mustPayToTheScript (Pool (LiquidityPool{lpCoinA=cA, lpCoinB= Coin $ unCoin cB}) lp1a) val1 <> 420 | Constraints.mustPayToTheScript (Pool (LiquidityPool{lpCoinA=cB, lpCoinB= Coin $ unCoin cC}) lp2a) val2 421 | 422 | logInfo @String $ printf "lp1 oldA = %d, lp1 oldB = %d, lp1 old product = %d, lp1 newA = %d, lp1 newB = %d, lp1 new product = %d" lp1oldA lp1oldB (unAmount lp1oldA * unAmount lp1oldB) lp1newA lp1newB (unAmount lp1newA * unAmount lp1newB) 423 | 424 | logInfo @String $ printf "lp2 oldB = %d, lp2 oldC = %d, lp2 old product = %d, lp2 newB = %d, lp2 newC = %d, lp2 new product = %d" lp2oldB lp2oldC (unAmount lp2oldB * unAmount lp2oldC) lp2newB lp2newC (unAmount lp2newB * unAmount lp2newC) 425 | return (tx, lookups) 426 | -- logInfo $ "arguments properly passed: " ++ show path 427 | 428 | -- logInfo $ "swapped with: " ++ show (LiquidityPool{lpCoinA=cA, lpCoinB= Coin $ unCoin cB}) ++ show (LiquidityPool{lpCoinA=cB, lpCoinB= Coin $ unCoin cC}) 429 | 430 | -- 431 | -- val = valueOf spCoinA newA <> valueOf spCoinB newB <> unitValue (poolStateCoin us) 432 | 433 | -- lookups = Constraints.typedValidatorLookups inst <> 434 | -- Constraints.otherScript (Scripts.validatorScript inst) <> 435 | -- Constraints.unspentOutputs (Map.singleton oref o) <> 436 | -- Constraints.ownPubKeyHash pkh 437 | 438 | -- tx = mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 439 | -- Constraints.mustPayToTheScript (Pool lp liquidity) val 440 | -- return [f, s, t] 441 | -- unless (spAmountA > 0 && spAmountB == 0 || spAmountA == 0 && spAmountB > 0) $ throwError "exactly one amount must be positive" 442 | 443 | _ -> throwError "problem passing args" 444 | -- return (Nothing, Nothing) 445 | logInfo $ show tx 446 | ledgerTx <- submitTxConstraintsWith lookups tx 447 | logInfo $ show ledgerTx 448 | void $ awaitTxConfirmed $ txId ledgerTx 449 | 450 | 451 | 452 | -- [first, second, third] 453 | -- (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us spCoinA spCoinB 454 | -- let outVal = txOutValue $ txOutTxOut o 455 | -- let oldA = amountOf outVal spCoinA 456 | -- oldB = amountOf outVal spCoinB 457 | -- (newA, newB) <- if spAmountA > 0 then do 458 | -- let outB = Amount $ findSwapA oldA oldB spAmountA 459 | -- when (outB == 0) $ throwError "no payout" 460 | -- return (oldA + spAmountA, oldB - outB) 461 | -- else do 462 | -- let outA = Amount $ findSwapB oldA oldB spAmountB 463 | -- when (outA == 0) $ throwError "no payout" 464 | -- return (oldA - outA, oldB + spAmountB) 465 | -- pkh <- pubKeyHash <$> ownPubKey 466 | 467 | -- logInfo @String $ printf "oldA = %d, oldB = %d, old product = %d, newA = %d, newB = %d, new product = %d" oldA oldB (unAmount oldA * unAmount oldB) newA newB (unAmount newA * unAmount newB) 468 | 469 | -- let inst = uniswapInstance us 470 | -- val = valueOf spCoinA newA <> valueOf spCoinB newB <> unitValue (poolStateCoin us) 471 | 472 | -- lookups = Constraints.typedValidatorLookups inst <> 473 | -- Constraints.otherScript (Scripts.validatorScript inst) <> 474 | -- Constraints.unspentOutputs (Map.singleton oref o) <> 475 | -- Constraints.ownPubKeyHash pkh 476 | 477 | -- tx = mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 478 | -- Constraints.mustPayToTheScript (Pool lp liquidity) val 479 | 480 | -- logInfo $ show tx 481 | -- ledgerTx <- submitTxConstraintsWith lookups tx 482 | -- logInfo $ show ledgerTx 483 | -- void $ awaitTxConfirmed $ txId ledgerTx 484 | -- logInfo $ "swapped with: " ++ show lp 485 | 486 | 487 | -- | Finds all liquidity pools and their liquidity belonging to the Uniswap instance. 488 | -- This merely inspects the blockchain and does not issue any transactions. 489 | pools :: forall w s. Uniswap -> Contract w s Text [((Coin A, Amount A), (Coin B, Amount B))] 490 | pools us = do 491 | utxos <- utxoAt (uniswapAddress us) 492 | go $ snd <$> Map.toList utxos 493 | where 494 | go :: [TxOutTx] -> Contract w s Text [((Coin A, Amount A), (Coin B, Amount B))] 495 | go [] = return [] 496 | go (o : os) = do 497 | let v = txOutValue $ txOutTxOut o 498 | if isUnity v c 499 | then do 500 | d <- getUniswapDatum o 501 | case d of 502 | Factory _ -> go os 503 | Pool lp _ -> do 504 | let coinA = lpCoinA lp 505 | coinB = lpCoinB lp 506 | amtA = amountOf v coinA 507 | amtB = amountOf v coinB 508 | s = ((coinA, amtA), (coinB, amtB)) 509 | logInfo $ "found pool: " ++ show s 510 | ss <- go os 511 | return $ s : ss 512 | else go os 513 | where 514 | c :: Coin PoolState 515 | c = poolStateCoin us 516 | 517 | -- | Gets the caller's funds. 518 | funds :: forall w s. Contract w s Text Value 519 | funds = do 520 | pkh <- pubKeyHash <$> ownPubKey 521 | os <- map snd . Map.toList <$> utxoAt (pubKeyHashAddress pkh) 522 | return $ mconcat [txOutValue $ txOutTxOut o | o <- os] 523 | 524 | getUniswapDatum :: TxOutTx -> Contract w s Text UniswapDatum 525 | getUniswapDatum o = case txOutDatumHash $ txOutTxOut o of 526 | Nothing -> throwError "datumHash not found" 527 | Just h -> case Map.lookup h $ txData $ txOutTxTx o of 528 | Nothing -> throwError "datum not found" 529 | Just (Datum e) -> case PlutusTx.fromBuiltinData e of 530 | Nothing -> throwError "datum has wrong type" 531 | Just d -> return d 532 | 533 | findUniswapInstance :: forall a b w s. Uniswap -> Coin b -> (UniswapDatum -> Maybe a) -> Contract w s Text (TxOutRef, TxOutTx, a) 534 | findUniswapInstance us c f = do 535 | let addr = uniswapAddress us 536 | logInfo @String $ printf "looking for Uniswap instance at address %s containing coin %s " (show addr) (show c) 537 | utxos <- utxoAt addr 538 | go [x | x@(_, o) <- Map.toList utxos, isUnity (txOutValue $ txOutTxOut o) c] 539 | where 540 | go [] = throwError "Uniswap instance not found" 541 | go ((oref, o) : xs) = do 542 | d <- getUniswapDatum o 543 | case f d of 544 | Nothing -> go xs 545 | Just a -> do 546 | logInfo @String $ printf "found Uniswap instance with datum: %s" (show d) 547 | return (oref, o, a) 548 | 549 | findUniswapFactory :: forall w s. Uniswap -> Contract w s Text (TxOutRef, TxOutTx, [LiquidityPool]) 550 | findUniswapFactory us@Uniswap{..} = findUniswapInstance us usCoin $ \case 551 | Factory lps -> Just lps 552 | Pool _ _ -> Nothing 553 | 554 | findUniswapPool :: forall w s. Uniswap -> LiquidityPool -> Contract w s Text (TxOutRef, TxOutTx, Amount Liquidity) 555 | findUniswapPool us lp = findUniswapInstance us (poolStateCoin us) $ \case 556 | Pool lp' l 557 | | lp == lp' -> Just l 558 | _ -> Nothing 559 | 560 | findUniswapFactoryAndPool :: forall w s. 561 | Uniswap 562 | -> Coin A 563 | -> Coin B 564 | -> Contract w s Text ( (TxOutRef, TxOutTx, [LiquidityPool]) 565 | , (TxOutRef, TxOutTx, LiquidityPool, Amount Liquidity) 566 | ) 567 | findUniswapFactoryAndPool us coinA coinB = do 568 | (oref1, o1, lps) <- findUniswapFactory us 569 | case [ lp' 570 | | lp' <- lps 571 | , lp' == LiquidityPool coinA coinB 572 | ] of 573 | [lp] -> do 574 | (oref2, o2, a) <- findUniswapPool us lp 575 | return ( (oref1, o1, lps) 576 | , (oref2, o2, lp, a) 577 | ) 578 | _ -> throwError "liquidity pool not found" 579 | 580 | findSwapA :: Amount A -> Amount B -> Amount A -> Integer 581 | findSwapA oldA oldB inA 582 | | ub' <= 1 = 0 583 | | otherwise = go 1 ub' 584 | where 585 | cs :: Integer -> Bool 586 | cs outB = checkSwap oldA oldB (oldA + inA) (oldB - Amount outB) 587 | 588 | ub' :: Integer 589 | ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] 590 | 591 | go :: Integer -> Integer -> Integer 592 | go lb ub 593 | | ub == (lb + 1) = lb 594 | | otherwise = 595 | let 596 | m = div (ub + lb) 2 597 | in 598 | if cs m then go m ub else go lb m 599 | 600 | findSwapB :: Amount A -> Amount B -> Amount B -> Integer 601 | findSwapB oldA oldB inB = findSwapA (switch oldB) (switch oldA) (switch inB) 602 | where 603 | switch = Amount . unAmount 604 | 605 | ownerEndpoint :: Contract (Last (Either Text Uniswap)) EmptySchema ContractError () 606 | ownerEndpoint = do 607 | e <- mapError absurd $ runError start 608 | void $ waitNSlots 1 609 | tell $ Last $ Just e 610 | 611 | -- | Provides the following endpoints for users of a Uniswap instance: 612 | -- 613 | -- [@create@]: Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. 614 | -- [@swap@]: Uses a liquidity pool two swap one sort of coins in the pool against the other. 615 | -- [@close@]: Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. 616 | -- [@remove@]: Removes some liquidity from a liquidity pool in exchange for liquidity tokens. 617 | -- [@add@]: Adds some liquidity to an existing liquidity pool in exchange for newly minted liquidity tokens. 618 | -- [@pools@]: Finds all liquidity pools and their liquidity belonging to the Uniswap instance. This merely inspects the blockchain and does not issue any transactions. 619 | -- [@funds@]: Gets the caller's funds. This merely inspects the blockchain and does not issue any transactions. 620 | -- [@stop@]: Stops the contract. 621 | userEndpoints :: Uniswap -> Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 622 | userEndpoints us = 623 | stop 624 | `select` 625 | (void (f (Proxy @"create") (const Created) create `select` 626 | f (Proxy @"swap") (const Swapped) swap `select` 627 | f (Proxy @"swap2") (const Swapped2) swap2 `select` 628 | f (Proxy @"close") (const Closed) close `select` 629 | f (Proxy @"remove") (const Removed) remove `select` 630 | f (Proxy @"add") (const Added) add `select` 631 | f (Proxy @"pools") Pools (\us' () -> pools us') `select` 632 | f (Proxy @"funds") Funds (\_us () -> funds)) 633 | <> userEndpoints us) 634 | where 635 | f :: forall l a p. 636 | (HasEndpoint l p UniswapUserSchema, FromJSON p) 637 | => Proxy l 638 | -> (a -> UserContractState) 639 | -> (Uniswap -> p -> Contract (Last (Either Text UserContractState)) UniswapUserSchema Text a) 640 | -> Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 641 | f _ g c = handleEndpoint @l $ \p -> do 642 | e <- either (pure . Left) (runError . c us) p 643 | tell $ Last $ Just $ case e of 644 | Left err -> Left err 645 | Right a -> Right $ g a 646 | 647 | stop :: Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 648 | stop = handleEndpoint @"stop" $ \e -> do 649 | tell $ Last $ Just $ case e of 650 | Left err -> Left err 651 | Right () -> Right Stopped 652 | -------------------------------------------------------------------------------- /src/Uniswap/OffChain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE LambdaCase #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NoImplicitPrelude #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE RecordWildCards #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TemplateHaskell #-} 14 | {-# LANGUAGE TypeApplications #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | 18 | module Uniswap.OffChain 19 | ( poolStateCoinFromUniswapCurrency, liquidityCoin 20 | , CreateParams (..) 21 | , SwapParams (..) 22 | , SwapParams2 (..) 23 | , CloseParams (..) 24 | , RemoveParams (..) 25 | , AddParams (..) 26 | , UniswapUserSchema, UserContractState (..) 27 | , UniswapOwnerSchema 28 | , start, create, add, remove, close, swap, pools 29 | , ownerEndpoint, userEndpoints, swapExactTokensForTokens, swapTokensForExactTokens 30 | -- , assetSymbol 31 | -- , assetToken1 32 | -- , assetToken2 33 | -- , assetToken3 34 | -- , toLookup 35 | -- , allLookups 36 | ) where 37 | 38 | import Control.Monad hiding (fmap) 39 | import qualified Data.Map as Map 40 | import Data.Monoid (Last (..)) 41 | import Data.Proxy (Proxy (..)) 42 | import Data.Text (Text, pack) 43 | import Data.List (tails, zipWith, take, drop, mapAccumL, last) 44 | import Data.Void (Void, absurd) 45 | import Ledger hiding (singleton) 46 | 47 | -- import Control.Monad hiding (fmap) 48 | -- import Control.Monad.Freer.Extras as Extras 49 | -- import Data.Default (Default (..)) 50 | -- import qualified Data.Map as Map 51 | -- import Data.Monoid (Last (..)) 52 | -- import Data.Text (Text) 53 | -- import Ledger 54 | import Ledger.Value (TokenName) 55 | -- import Ledger.Ada as Ada 56 | -- import Plutus.Contract as Contract 57 | -- import Plutus.Trace.Emulator as Emulator 58 | -- import PlutusTx.Prelude hiding (Semigroup(..), unless) 59 | -- import Prelude (IO, Semigroup(..), Show (..)) 60 | -- import Wallet.Emulator.Wallet 61 | 62 | import Ledger.Constraints as Constraints 63 | import Ledger.Typed.Scripts as Scripts 64 | import Playground.Contract 65 | import Plutus.Contract 66 | import qualified Plutus.Contracts.Currency as Currency 67 | import Uniswap.OnChain (mkUniswapValidator, validateLiquidityMinting) 68 | import Uniswap.Pool 69 | import Uniswap.Types 70 | import qualified PlutusTx 71 | import PlutusTx.Prelude hiding (Semigroup (..), dropWhile, flip, unless) 72 | import Prelude as Haskell (Int, Semigroup (..), String, div, mconcat, dropWhile, flip, show, 73 | (^)) 74 | import Text.Printf (printf) 75 | 76 | 77 | data Uniswapping 78 | instance Scripts.ValidatorTypes Uniswapping where 79 | type instance RedeemerType Uniswapping = UniswapAction 80 | type instance DatumType Uniswapping = UniswapDatum 81 | 82 | type UniswapOwnerSchema = Endpoint "start" () 83 | 84 | -- | Schema for the endpoints for users of Uniswap. 85 | type UniswapUserSchema = 86 | Endpoint "create" CreateParams 87 | .\/ Endpoint "swap" SwapParams 88 | .\/ Endpoint "swapExactTokensForTokens" SwapParams2 89 | .\/ Endpoint "swapTokensForExactTokens" SwapParams2 90 | .\/ Endpoint "close" CloseParams 91 | .\/ Endpoint "remove" RemoveParams 92 | .\/ Endpoint "add" AddParams 93 | .\/ Endpoint "pools" () 94 | .\/ Endpoint "funds" () 95 | .\/ Endpoint "stop" () 96 | 97 | -- | Type of the Uniswap user contract state. 98 | data UserContractState = 99 | Pools [((Coin A, Amount A), (Coin B, Amount B))] 100 | | Funds Value 101 | | Created 102 | | Swapped 103 | | Swapped2 104 | | Added 105 | | Removed 106 | | Closed 107 | | Stopped 108 | deriving (Show, Generic, FromJSON, ToJSON) 109 | 110 | 111 | uniswapTokenName, poolStateTokenName :: TokenName 112 | uniswapTokenName = "Uniswap" 113 | poolStateTokenName = "Pool State" 114 | 115 | uniswapInstance :: Uniswap -> Scripts.TypedValidator Uniswapping 116 | uniswapInstance us = Scripts.mkTypedValidator @Uniswapping 117 | ($$(PlutusTx.compile [|| mkUniswapValidator ||]) 118 | `PlutusTx.applyCode` PlutusTx.liftCode us 119 | `PlutusTx.applyCode` PlutusTx.liftCode c) 120 | $$(PlutusTx.compile [|| wrap ||]) 121 | where 122 | c :: Coin PoolState 123 | c = poolStateCoin us 124 | 125 | wrap = Scripts.wrapValidator @UniswapDatum @UniswapAction 126 | 127 | uniswapScript :: Uniswap -> Validator 128 | uniswapScript = Scripts.validatorScript . uniswapInstance 129 | 130 | uniswapAddress :: Uniswap -> Ledger.Address 131 | uniswapAddress = Ledger.scriptAddress . uniswapScript 132 | 133 | uniswap :: CurrencySymbol -> Uniswap 134 | uniswap cs = Uniswap $ mkCoin cs uniswapTokenName 135 | 136 | liquidityPolicy :: Uniswap -> MintingPolicy 137 | liquidityPolicy us = mkMintingPolicyScript $ 138 | $$(PlutusTx.compile [|| \u t -> Scripts.wrapMintingPolicy (validateLiquidityMinting u t) ||]) 139 | `PlutusTx.applyCode` PlutusTx.liftCode us 140 | `PlutusTx.applyCode` PlutusTx.liftCode poolStateTokenName 141 | 142 | liquidityCurrency :: Uniswap -> CurrencySymbol 143 | liquidityCurrency = scriptCurrencySymbol . liquidityPolicy 144 | 145 | poolStateCoin :: Uniswap -> Coin PoolState 146 | poolStateCoin = flip mkCoin poolStateTokenName . liquidityCurrency 147 | 148 | -- | Gets the 'Coin' used to identity liquidity pools. 149 | poolStateCoinFromUniswapCurrency :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. 150 | -> Coin PoolState 151 | poolStateCoinFromUniswapCurrency = poolStateCoin . uniswap 152 | 153 | -- | Gets the liquidity token for a given liquidity pool. 154 | liquidityCoin :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. 155 | -> Coin A -- ^ One coin in the liquidity pair. 156 | -> Coin B -- ^ The other coin in the liquidity pair. 157 | -> Coin Liquidity 158 | liquidityCoin cs coinA coinB = mkCoin (liquidityCurrency $ uniswap cs) $ lpTicker $ LiquidityPool coinA coinB 159 | 160 | -- | Parameters for the @create@-endpoint, which creates a new liquidity pool. 161 | data CreateParams = CreateParams 162 | { cpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 163 | , cpCoinB :: Coin B -- ^ The other 'Coin'. 164 | , cpAmountA :: Amount A -- ^ Amount of liquidity for the first 'Coin'. 165 | , cpAmountB :: Amount B -- ^ Amount of liquidity for the second 'Coin'. 166 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 167 | 168 | -- | Parameters for the @swap@-endpoint, which allows swaps between the two different coins in a liquidity pool. 169 | -- One of the provided amounts must be positive, the other must be zero. 170 | data SwapParams = SwapParams 171 | { spCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 172 | , spCoinB :: Coin B -- ^ The other 'Coin'. 173 | , spAmountA :: Amount A -- ^ The amount the first 'Coin' that should be swapped. 174 | , spAmountB :: Amount B -- ^ The amount of the second 'Coin' that should be swapped. 175 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 176 | 177 | data SwapParams2 = SwapParams2 178 | { 179 | amount :: Amount A 180 | , path :: [Coin A] 181 | -- spCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 182 | -- , spCoinB :: Coin B -- ^ The other 'Coin'. 183 | -- , spAmountA :: Amount A -- ^ The amount the first 'Coin' that should be swapped. 184 | -- , spAmountB :: Amount B -- ^ The amount of the second 'Coin' that should be swapped. 185 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 186 | 187 | -- | Parameters for the @close@-endpoint, which closes a liquidity pool. 188 | data CloseParams = CloseParams 189 | { clpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 190 | , clpCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 191 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 192 | 193 | -- | Parameters for the @remove@-endpoint, which removes some liquidity from a liquidity pool. 194 | data RemoveParams = RemoveParams 195 | { rpCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 196 | , rpCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 197 | , rpDiff :: Amount Liquidity -- ^ The amount of liquidity tokens to burn in exchange for liquidity from the pool. 198 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 199 | 200 | -- | Parameters for the @add@-endpoint, which adds liquidity to a liquidity pool in exchange for liquidity tokens. 201 | data AddParams = AddParams 202 | { apCoinA :: Coin A -- ^ One 'Coin' of the liquidity pair. 203 | , apCoinB :: Coin B -- ^ The other 'Coin' of the liquidity pair. 204 | , apAmountA :: Amount A -- ^ The amount of coins of the first kind to add to the pool. 205 | , apAmountB :: Amount B -- ^ The amount of coins of the second kind to add to the pool. 206 | } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) 207 | 208 | -- | Creates a Uniswap "factory". This factory will keep track of the existing liquidity pools and enforce that there will be at most one liquidity pool 209 | -- for any pair of tokens at any given time. 210 | start :: forall w s. Contract w s Text Uniswap 211 | start = do 212 | pkh <- pubKeyHash <$> ownPubKey 213 | cs <- fmap Currency.currencySymbol $ 214 | mapError (pack . show @Currency.CurrencyError) $ 215 | Currency.mintContract pkh [(uniswapTokenName, 1)] 216 | let c = mkCoin cs uniswapTokenName 217 | us = uniswap cs 218 | inst = uniswapInstance us 219 | tx = mustPayToTheScript (Factory []) $ unitValue c 220 | ledgerTx <- submitTxConstraints inst tx 221 | void $ awaitTxConfirmed $ txId ledgerTx 222 | void $ waitNSlots 1 223 | 224 | logInfo @String $ printf "started Uniswap %s at address %s" (show us) (show $ uniswapAddress us) 225 | return us 226 | 227 | -- | Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. 228 | create :: forall w s. Uniswap -> CreateParams -> Contract w s Text () 229 | create us CreateParams{..} = do 230 | when (unCoin cpCoinA == unCoin cpCoinB) $ throwError "coins must be different" 231 | when (cpAmountA <= 0 || cpAmountB <= 0) $ throwError "amounts must be positive" 232 | (oref, o, lps) <- findUniswapFactory us 233 | let liquidity = calculateInitialLiquidity cpAmountA cpAmountB 234 | lp = LiquidityPool {lpCoinA = cpCoinA, lpCoinB = cpCoinB} 235 | let usInst = uniswapInstance us 236 | usScript = uniswapScript us 237 | usDat1 = Factory $ lp : lps 238 | usDat2 = Pool lp liquidity 239 | psC = poolStateCoin us 240 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 241 | usVal = unitValue $ usCoin us 242 | lpVal = valueOf cpCoinA cpAmountA <> valueOf cpCoinB cpAmountB <> unitValue psC 243 | 244 | lookups = Constraints.typedValidatorLookups usInst <> 245 | Constraints.otherScript usScript <> 246 | Constraints.mintingPolicy (liquidityPolicy us) <> 247 | Constraints.unspentOutputs (Map.singleton oref o) 248 | 249 | tx = Constraints.mustPayToTheScript usDat1 usVal <> 250 | Constraints.mustPayToTheScript usDat2 lpVal <> 251 | Constraints.mustMintValue (unitValue psC <> valueOf lC liquidity) <> 252 | Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData $ Create lp) 253 | 254 | ledgerTx <- submitTxConstraintsWith lookups tx 255 | void $ awaitTxConfirmed $ txId ledgerTx 256 | 257 | logInfo $ "created liquidity pool: " ++ show lp 258 | 259 | -- | Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. 260 | close :: forall w s. Uniswap -> CloseParams -> Contract w s Text () 261 | close us CloseParams{..} = do 262 | ((oref1, o1, lps), (oref2, o2, lp, liquidity)) <- findUniswapFactoryAndPool us clpCoinA clpCoinB 263 | pkh <- pubKeyHash <$> ownPubKey 264 | let usInst = uniswapInstance us 265 | usScript = uniswapScript us 266 | usDat = Factory $ filter (/= lp) lps 267 | usC = usCoin us 268 | psC = poolStateCoin us 269 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 270 | usVal = unitValue usC 271 | psVal = unitValue psC 272 | lVal = valueOf lC liquidity 273 | redeemer = Redeemer $ PlutusTx.toBuiltinData Close 274 | 275 | lookups = Constraints.typedValidatorLookups usInst <> 276 | Constraints.otherScript usScript <> 277 | Constraints.mintingPolicy (liquidityPolicy us) <> 278 | Constraints.ownPubKeyHash pkh <> 279 | Constraints.unspentOutputs (Map.singleton oref1 o1 <> Map.singleton oref2 o2) 280 | 281 | tx = Constraints.mustPayToTheScript usDat usVal <> 282 | Constraints.mustMintValue (negate $ psVal <> lVal) <> 283 | Constraints.mustSpendScriptOutput oref1 redeemer <> 284 | Constraints.mustSpendScriptOutput oref2 redeemer <> 285 | Constraints.mustIncludeDatum (Datum $ PlutusTx.toBuiltinData $ Pool lp liquidity) 286 | 287 | ledgerTx <- submitTxConstraintsWith lookups tx 288 | void $ awaitTxConfirmed $ txId ledgerTx 289 | 290 | logInfo $ "closed liquidity pool: " ++ show lp 291 | 292 | -- | Removes some liquidity from a liquidity pool in exchange for liquidity tokens. 293 | remove :: forall w s. Uniswap -> RemoveParams -> Contract w s Text () 294 | remove us RemoveParams{..} = do 295 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us rpCoinA rpCoinB 296 | pkh <- pubKeyHash <$> ownPubKey 297 | when (rpDiff < 1 || rpDiff >= liquidity) $ throwError "removed liquidity must be positive and less than total liquidity" 298 | let usInst = uniswapInstance us 299 | usScript = uniswapScript us 300 | dat = Pool lp $ liquidity - rpDiff 301 | psC = poolStateCoin us 302 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 303 | psVal = unitValue psC 304 | lVal = valueOf lC rpDiff 305 | inVal = txOutValue $ txOutTxOut o 306 | inA = amountOf inVal rpCoinA 307 | inB = amountOf inVal rpCoinB 308 | (outA, outB) = calculateRemoval inA inB liquidity rpDiff 309 | val = psVal <> valueOf rpCoinA outA <> valueOf rpCoinB outB 310 | redeemer = Redeemer $ PlutusTx.toBuiltinData Remove 311 | 312 | lookups = Constraints.typedValidatorLookups usInst <> 313 | Constraints.otherScript usScript <> 314 | Constraints.mintingPolicy (liquidityPolicy us) <> 315 | Constraints.unspentOutputs (Map.singleton oref o) <> 316 | Constraints.ownPubKeyHash pkh 317 | 318 | tx = Constraints.mustPayToTheScript dat val <> 319 | Constraints.mustMintValue (negate lVal) <> 320 | Constraints.mustSpendScriptOutput oref redeemer 321 | 322 | ledgerTx <- submitTxConstraintsWith lookups tx 323 | void $ awaitTxConfirmed $ txId ledgerTx 324 | 325 | logInfo $ "removed liquidity from pool: " ++ show lp 326 | 327 | -- | Adds some liquidity to an existing liquidity pool in exchange for newly minted liquidity tokens. 328 | add :: forall w s. Uniswap -> AddParams -> Contract w s Text () 329 | add us AddParams{..} = do 330 | pkh <- pubKeyHash <$> ownPubKey 331 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us apCoinA apCoinB 332 | when (apAmountA < 0 || apAmountB < 0) $ throwError "amounts must not be negative" 333 | let outVal = txOutValue $ txOutTxOut o 334 | oldA = amountOf outVal apCoinA 335 | oldB = amountOf outVal apCoinB 336 | newA = oldA + apAmountA 337 | newB = oldB + apAmountB 338 | delL = calculateAdditionalLiquidity oldA oldB liquidity apAmountA apAmountB 339 | inVal = valueOf apCoinA apAmountA <> valueOf apCoinB apAmountB 340 | when (delL <= 0) $ throwError "insufficient liquidity" 341 | logInfo @String $ printf "oldA = %d, oldB = %d, newA = %d, newB = %d, delL = %d" oldA oldB newA newB delL 342 | 343 | let usInst = uniswapInstance us 344 | usScript = uniswapScript us 345 | dat = Pool lp $ liquidity + delL 346 | psC = poolStateCoin us 347 | lC = mkCoin (liquidityCurrency us) $ lpTicker lp 348 | psVal = unitValue psC 349 | lVal = valueOf lC delL 350 | val = psVal <> valueOf apCoinA newA <> valueOf apCoinB newB 351 | redeemer = Redeemer $ PlutusTx.toBuiltinData Add 352 | 353 | lookups = Constraints.typedValidatorLookups usInst <> 354 | Constraints.otherScript usScript <> 355 | Constraints.mintingPolicy (liquidityPolicy us) <> 356 | Constraints.ownPubKeyHash pkh <> 357 | Constraints.unspentOutputs (Map.singleton oref o) 358 | 359 | tx = Constraints.mustPayToTheScript dat val <> 360 | Constraints.mustMintValue lVal <> 361 | Constraints.mustSpendScriptOutput oref redeemer 362 | 363 | logInfo @String $ printf "val = %s, inVal = %s" (show val) (show inVal) 364 | logInfo $ show lookups 365 | logInfo $ show tx 366 | 367 | ledgerTx <- submitTxConstraintsWith lookups tx 368 | void $ awaitTxConfirmed $ txId ledgerTx 369 | 370 | logInfo $ "added liquidity to pool: " ++ show lp 371 | 372 | -- | Uses a liquidity pool two swap one sort of coins in the pool against the other. 373 | swap :: forall w s. Uniswap -> SwapParams -> Contract w s Text () 374 | swap us SwapParams{..} = do 375 | unless (spAmountA > 0 && spAmountB == 0 || spAmountA == 0 && spAmountB > 0) $ throwError "exactly one amount must be positive" 376 | (_, (oref, o, lp, liquidity)) <- findUniswapFactoryAndPool us spCoinA spCoinB 377 | let outVal = txOutValue $ txOutTxOut o 378 | let oldA = amountOf outVal spCoinA 379 | oldB = amountOf outVal spCoinB 380 | (newA, newB) <- if spAmountA > 0 then do 381 | let outB = Amount $ getAmountOutA oldA oldB spAmountA 382 | when (outB == 0) $ throwError "no payout" 383 | return (oldA + spAmountA, oldB - outB) 384 | else do 385 | let outA = Amount $ getAmountOutB oldA oldB spAmountB 386 | when (outA == 0) $ throwError "no payout" 387 | return (oldA - outA, oldB + spAmountB) 388 | pkh <- pubKeyHash <$> ownPubKey 389 | 390 | logInfo @String $ printf "oldA = %d, oldB = %d, old product = %d, newA = %d, newB = %d, new product = %d" oldA oldB (unAmount oldA * unAmount oldB) newA newB (unAmount newA * unAmount newB) 391 | 392 | let inst = uniswapInstance us 393 | val = valueOf spCoinA newA <> valueOf spCoinB newB <> unitValue (poolStateCoin us) 394 | 395 | lookups = Constraints.typedValidatorLookups inst <> 396 | Constraints.otherScript (Scripts.validatorScript inst) <> 397 | Constraints.unspentOutputs (Map.singleton oref o) <> 398 | Constraints.ownPubKeyHash pkh 399 | 400 | tx = mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 401 | Constraints.mustPayToTheScript (Pool lp liquidity) val 402 | 403 | logInfo $ show tx 404 | ledgerTx <- submitTxConstraintsWith lookups tx 405 | logInfo $ show ledgerTx 406 | void $ awaitTxConfirmed $ txId ledgerTx 407 | logInfo $ "swapped with: " ++ show lp 408 | 409 | 410 | 411 | swapTokensForExactTokens :: forall w s. Uniswap -> SwapParams2 -> Contract w s Text () 412 | swapTokensForExactTokens us SwapParams2{..} = do 413 | (tx, lookups) <- case path of 414 | p:ps -> do 415 | logInfo @String $ printf "Swapping " ++ show path ++ show inst 416 | pkh <- pubKeyHash <$> ownPubKey 417 | lookups <- allLookups path2rev $ Constraints.ownPubKeyHash pkh <> Constraints.typedValidatorLookups inst <> Constraints.otherScript (Scripts.validatorScript inst) 418 | 419 | out <- mapAccumLM (\aux a -> toTrx a aux) (Amount $ unAmount amount) path2rev 420 | logInfo @String $ printf "You may spend " ++ show (fst out) ++ show (last $ last path2rev) 421 | 422 | let trx = Haskell.mconcat $ snd out 423 | return (trx, lookups) 424 | where 425 | allLookups [] strt = return strt 426 | allLookups (p:ps) strt = do 427 | new <- toLookup us inst p 428 | rest <- allLookups ps strt 429 | return (new <> rest) 430 | 431 | mapAccumLM :: Monad m => (a -> b -> m(a, c)) -> a -> [b] -> m(a, [c]) 432 | mapAccumLM _ a [] = return (a, []) 433 | mapAccumLM f a (x:xs) = do 434 | (a', c) <- f a x 435 | (a'', cs) <- mapAccumLM f a' xs 436 | return (a'', c:cs) 437 | 438 | f n m xs = zipWith const (Data.List.take n <$> tails xs) (drop m xs) 439 | 440 | 441 | inst = uniswapInstance us 442 | path2rev = reverse $ f 2 1 path 443 | 444 | toLookup us inst [c11, c22]= do (_, (oref, o, _, _)) <- findUniswapFactoryAndPool us c11 $ Coin $ unCoin c22 445 | return $ Constraints.unspentOutputs (Map.singleton oref o) 446 | 447 | toTrx [c1, c2] amnt = do (_, (oref, o, lp, a)) <- findUniswapFactoryAndPool us c1 $ Coin $ unCoin c2 448 | let outVal = txOutValue $ txOutTxOut o 449 | oldA = amountOf outVal c1 450 | oldB = amountOf outVal $ Coin $ unCoin c2 451 | inA = Amount $ getAmountInB oldA oldB amnt 452 | (newA, newB) = (oldA + inA, oldB - (Amount $ unAmount amnt)) 453 | 454 | val = valueOf c1 newA <> valueOf c2 (Amount $ unAmount newB) <> unitValue (poolStateCoin us) 455 | trx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 456 | Constraints.mustPayToTheScript (Pool lp a) val 457 | logInfo @String $ printf "oldA = %d, oldB = %d, old product = %d, newA = %d, newB = %d, new product = %d" oldA oldB (unAmount oldA * unAmount oldB) newA newB (unAmount newA * unAmount newB) 458 | 459 | return ((Amount $ unAmount inA), trx) 460 | 461 | 462 | _ -> throwError "problem passing args" 463 | 464 | logInfo $ show tx 465 | ledgerTx <- submitTxConstraintsWith lookups tx 466 | logInfo $ show ledgerTx 467 | void $ awaitTxConfirmed $ txId ledgerTx 468 | 469 | 470 | 471 | swapExactTokensForTokens :: forall w s. Uniswap -> SwapParams2 -> Contract w s Text () 472 | swapExactTokensForTokens us SwapParams2{..} = do 473 | (tx, lookups) <- case path of 474 | p:ps -> do 475 | logInfo @String $ printf "Swapping " ++ show path ++ show inst 476 | pkh <- pubKeyHash <$> ownPubKey 477 | lookups <- allLookups path2 $ Constraints.ownPubKeyHash pkh <> Constraints.typedValidatorLookups inst <> Constraints.otherScript (Scripts.validatorScript inst) 478 | 479 | out <- mapAccumLM (\aux a -> toTrx a aux) amount path2 480 | logInfo @String $ printf "You may receive " ++ show (fst out) ++ show (last $ last path2) 481 | 482 | let trx = Haskell.mconcat $ snd out 483 | return (trx, lookups) 484 | where 485 | allLookups [] strt = return strt 486 | allLookups (p:ps) strt = do 487 | new <- toLookup us inst p 488 | rest <- allLookups ps strt 489 | return (new <> rest) 490 | 491 | mapAccumLM :: Monad m => (a -> b -> m(a, c)) -> a -> [b] -> m(a, [c]) 492 | mapAccumLM _ a [] = return (a, []) 493 | mapAccumLM f a (x:xs) = do 494 | (a', c) <- f a x 495 | (a'', cs) <- mapAccumLM f a' xs 496 | return (a'', c:cs) 497 | 498 | f n m xs = zipWith const (Data.List.take n <$> tails xs) (drop m xs) 499 | 500 | 501 | inst = uniswapInstance us 502 | path2 = f 2 1 path 503 | 504 | toLookup us inst [c11, c22]= do (_, (oref, o, _, _)) <- findUniswapFactoryAndPool us c11 $ Coin $ unCoin c22 505 | return $ Constraints.unspentOutputs (Map.singleton oref o) 506 | 507 | toTrx [c1, c2] amnt = do (_, (oref, o, lp, a)) <- findUniswapFactoryAndPool us c1 $ Coin $ unCoin c2 508 | let outVal = txOutValue $ txOutTxOut o 509 | oldA = amountOf outVal c1 510 | oldB = amountOf outVal $ Coin $ unCoin c2 511 | outB = Amount $ getAmountOutA oldA oldB amnt 512 | (newA, newB) = (oldA + amnt, oldB - (Amount $ unAmount outB)) 513 | 514 | val = valueOf c1 newA <> valueOf c2 (Amount $ unAmount newB) <> unitValue (poolStateCoin us) 515 | trx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toBuiltinData Swap) <> 516 | Constraints.mustPayToTheScript (Pool lp a) val 517 | logInfo @String $ printf "oldA = %d, oldB = %d, old product = %d, newA = %d, newB = %d, new product = %d" oldA oldB (unAmount oldA * unAmount oldB) newA newB (unAmount newA * unAmount newB) 518 | 519 | return ((Amount $ unAmount outB), trx) 520 | 521 | 522 | _ -> throwError "problem passing args" 523 | 524 | logInfo $ show tx 525 | ledgerTx <- submitTxConstraintsWith lookups tx 526 | logInfo $ show ledgerTx 527 | void $ awaitTxConfirmed $ txId ledgerTx 528 | 529 | 530 | 531 | -- | Finds all liquidity pools and their liquidity belonging to the Uniswap instance. 532 | -- This merely inspects the blockchain and does not issue any transactions. 533 | pools :: forall w s. Uniswap -> Contract w s Text [((Coin A, Amount A), (Coin B, Amount B))] 534 | pools us = do 535 | utxos <- utxoAt (uniswapAddress us) 536 | go $ snd <$> Map.toList utxos 537 | where 538 | go :: [TxOutTx] -> Contract w s Text [((Coin A, Amount A), (Coin B, Amount B))] 539 | go [] = return [] 540 | go (o : os) = do 541 | let v = txOutValue $ txOutTxOut o 542 | if isUnity v c 543 | then do 544 | d <- getUniswapDatum o 545 | case d of 546 | Factory _ -> go os 547 | Pool lp _ -> do 548 | let coinA = lpCoinA lp 549 | coinB = lpCoinB lp 550 | amtA = amountOf v coinA 551 | amtB = amountOf v coinB 552 | s = ((coinA, amtA), (coinB, amtB)) 553 | logInfo $ "found pool: " ++ show s 554 | ss <- go os 555 | return $ s : ss 556 | else go os 557 | where 558 | c :: Coin PoolState 559 | c = poolStateCoin us 560 | 561 | -- | Gets the caller's funds. 562 | funds :: forall w s. Contract w s Text Value 563 | funds = do 564 | pkh <- pubKeyHash <$> ownPubKey 565 | os <- map snd . Map.toList <$> utxoAt (pubKeyHashAddress pkh) 566 | return $ PlutusTx.Prelude.mconcat [txOutValue $ txOutTxOut o | o <- os] 567 | 568 | getUniswapDatum :: TxOutTx -> Contract w s Text UniswapDatum 569 | getUniswapDatum o = case txOutDatumHash $ txOutTxOut o of 570 | Nothing -> throwError "datumHash not found" 571 | Just h -> case Map.lookup h $ txData $ txOutTxTx o of 572 | Nothing -> throwError "datum not found" 573 | Just (Datum e) -> case PlutusTx.fromBuiltinData e of 574 | Nothing -> throwError "datum has wrong type" 575 | Just d -> return d 576 | 577 | findUniswapInstance :: forall a b w s. Uniswap -> Coin b -> (UniswapDatum -> Maybe a) -> Contract w s Text (TxOutRef, TxOutTx, a) 578 | findUniswapInstance us c f = do 579 | let addr = uniswapAddress us 580 | logInfo @String $ printf "looking for Uniswap instance at address %s containing coin %s " (show addr) (show c) 581 | utxos <- utxoAt addr 582 | go [x | x@(_, o) <- Map.toList utxos, isUnity (txOutValue $ txOutTxOut o) c] 583 | where 584 | go [] = throwError "Uniswap instance not found" 585 | go ((oref, o) : xs) = do 586 | d <- getUniswapDatum o 587 | case f d of 588 | Nothing -> go xs 589 | Just a -> do 590 | logInfo @String $ printf "found Uniswap instance with datum: %s" (show d) 591 | return (oref, o, a) 592 | 593 | findUniswapFactory :: forall w s. Uniswap -> Contract w s Text (TxOutRef, TxOutTx, [LiquidityPool]) 594 | findUniswapFactory us@Uniswap{..} = findUniswapInstance us usCoin $ \case 595 | Factory lps -> Just lps 596 | Pool _ _ -> Nothing 597 | 598 | findUniswapPool :: forall w s. Uniswap -> LiquidityPool -> Contract w s Text (TxOutRef, TxOutTx, Amount Liquidity) 599 | findUniswapPool us lp = findUniswapInstance us (poolStateCoin us) $ \case 600 | Pool lp' l 601 | | lp == lp' -> Just l 602 | _ -> Nothing 603 | 604 | findUniswapFactoryAndPool :: forall w s. 605 | Uniswap 606 | -> Coin A 607 | -> Coin B 608 | -> Contract w s Text ( (TxOutRef, TxOutTx, [LiquidityPool]) 609 | , (TxOutRef, TxOutTx, LiquidityPool, Amount Liquidity) 610 | ) 611 | findUniswapFactoryAndPool us coinA coinB = do 612 | (oref1, o1, lps) <- findUniswapFactory us 613 | case [ lp' 614 | | lp' <- lps 615 | , lp' == LiquidityPool coinA coinB 616 | ] of 617 | [lp] -> do 618 | (oref2, o2, a) <- findUniswapPool us lp 619 | return ( (oref1, o1, lps) 620 | , (oref2, o2, lp, a) 621 | ) 622 | _ -> throwError "liquidity pool not found" 623 | 624 | 625 | getAmountInA :: Amount A -> Amount B -> Amount A -> Integer 626 | getAmountInA oldA oldB outA 627 | | ub' <= 1 = 0 628 | | otherwise = go 1 ub' 629 | where 630 | cs :: Integer -> Bool 631 | cs inB = not $ checkSwap oldA oldB (oldA - outA) (oldB + Amount inB) 632 | 633 | ub' :: Integer 634 | ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] 635 | 636 | go :: Integer -> Integer -> Integer 637 | go lb ub 638 | | ub == (lb + 1) = ub 639 | | otherwise = 640 | let 641 | m = div (ub + lb) 2 642 | in 643 | if cs m then go m ub else go lb m 644 | 645 | getAmountInB :: Amount A -> Amount B -> Amount B -> Integer 646 | getAmountInB oldA oldB outB = getAmountInA (switch oldB) (switch oldA) (switch outB) 647 | where 648 | switch = Amount . unAmount 649 | 650 | 651 | getAmountOutA :: Amount A -> Amount B -> Amount A -> Integer 652 | getAmountOutA oldA oldB inA 653 | | ub' <= 1 = 0 654 | | otherwise = go 1 ub' 655 | where 656 | cs :: Integer -> Bool 657 | cs outB = checkSwap oldA oldB (oldA + inA) (oldB - Amount outB) 658 | 659 | ub' :: Integer 660 | ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] 661 | 662 | go :: Integer -> Integer -> Integer 663 | go lb ub 664 | | ub == (lb + 1) = lb 665 | | otherwise = 666 | let 667 | m = div (ub + lb) 2 668 | in 669 | if cs m then go m ub else go lb m 670 | 671 | getAmountOutB :: Amount A -> Amount B -> Amount B -> Integer 672 | getAmountOutB oldA oldB inB = getAmountOutA (switch oldB) (switch oldA) (switch inB) 673 | where 674 | switch = Amount . unAmount 675 | 676 | ownerEndpoint :: Contract (Last (Either Text Uniswap)) EmptySchema ContractError () 677 | ownerEndpoint = do 678 | e <- mapError absurd $ runError start 679 | void $ waitNSlots 1 680 | tell $ Last $ Just e 681 | 682 | -- | Provides the following endpoints for users of a Uniswap instance: 683 | -- 684 | -- [@create@]: Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. 685 | -- [@swap@]: Uses a liquidity pool two swap one sort of coins in the pool against the other. 686 | -- [@close@]: Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. 687 | -- [@remove@]: Removes some liquidity from a liquidity pool in exchange for liquidity tokens. 688 | -- [@add@]: Adds some liquidity to an existing liquidity pool in exchange for newly minted liquidity tokens. 689 | -- [@pools@]: Finds all liquidity pools and their liquidity belonging to the Uniswap instance. This merely inspects the blockchain and does not issue any transactions. 690 | -- [@funds@]: Gets the caller's funds. This merely inspects the blockchain and does not issue any transactions. 691 | -- [@stop@]: Stops the contract. 692 | userEndpoints :: Uniswap -> Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 693 | userEndpoints us = 694 | stop 695 | `select` 696 | (void (f (Proxy @"create") (const Created) create `select` 697 | f (Proxy @"swap") (const Swapped) swap `select` 698 | f (Proxy @"swapExactTokensForTokens") (const Swapped2) swapExactTokensForTokens `select` 699 | f (Proxy @"swapTokensForExactTokens") (const Swapped2) swapTokensForExactTokens `select` 700 | f (Proxy @"close") (const Closed) close `select` 701 | f (Proxy @"remove") (const Removed) remove `select` 702 | f (Proxy @"add") (const Added) add `select` 703 | f (Proxy @"pools") Pools (\us' () -> pools us') `select` 704 | f (Proxy @"funds") Funds (\_us () -> funds)) 705 | <> userEndpoints us) 706 | where 707 | f :: forall l a p. 708 | (HasEndpoint l p UniswapUserSchema, FromJSON p) 709 | => Proxy l 710 | -> (a -> UserContractState) 711 | -> (Uniswap -> p -> Contract (Last (Either Text UserContractState)) UniswapUserSchema Text a) 712 | -> Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 713 | f _ g c = handleEndpoint @l $ \p -> do 714 | e <- either (pure . Left) (runError . c us) p 715 | tell $ Last $ Just $ case e of 716 | Left err -> Left err 717 | Right a -> Right $ g a 718 | 719 | stop :: Promise (Last (Either Text UserContractState)) UniswapUserSchema Void () 720 | stop = handleEndpoint @"stop" $ \e -> do 721 | tell $ Last $ Just $ case e of 722 | Left err -> Left err 723 | Right () -> Right Stopped 724 | --------------------------------------------------------------------------------