diff --git a/AltLabs/dex-token-swap/pab/Main.hs b/AltLabs/dex-token-swap/pab/Main.hs index 8f4fd293f..a1b395138 100644 --- a/AltLabs/dex-token-swap/pab/Main.hs +++ b/AltLabs/dex-token-swap/pab/Main.hs @@ -54,6 +54,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath (()) import Plutus.PAB.Core (PABEffects) import Ledger (CurrencySymbol) +import Plutus.Contracts.Data uniswapMintingContract :: Eff (PABEffects (Builtin UniswapContracts) @@ -99,7 +100,7 @@ uniswapLiquidityPoolContract cids cs = do let coins = Map.fromList [(tn, Uniswap.mkCoin cs tn) | tn <- tokenNames] ada = Uniswap.mkCoin adaSymbol adaToken - let cp = Uniswap.CreateParams ada (coins Map.! "A") 100000 500000 + let cp = CreateParams ada (coins Map.! "A") 100000 500000 Simulator.logString @(Builtin UniswapContracts) $ "creating liquidity pool: " ++ show (encode cp) -- _ <- Simulator.callEndpointOnInstance (cids Map.! Wallet 2) "create" cp let cid2 = cids Map.! Wallet 2 @@ -141,7 +142,7 @@ main = do outputDir <- getCurrentDirectory print outputDir BSL.writeFile - (outputDir "full_report_response.json") + (outputDir "./log/full_report_response.json") (JSON.encodePretty fullReport) data UniswapContracts = diff --git a/AltLabs/dex-token-swap/plutus-starter.cabal b/AltLabs/dex-token-swap/plutus-starter.cabal index a4ca19275..58f53dea2 100644 --- a/AltLabs/dex-token-swap/plutus-starter.cabal +++ b/AltLabs/dex-token-swap/plutus-starter.cabal @@ -39,10 +39,14 @@ library -- Plutus.PAB.Effects.ContractTest.Uniswap Effects.Uniswap Plutus.Contracts.Data + Plutus.Contracts.Helpers + -- Plutus.Contracts.UniswapHelpers + Plutus.Contracts.Validators Plutus.Contracts.PubKey Plutus.Contracts.Uniswap Plutus.Contracts.Currency Plutus.Contracts.LiquidityPool + Plutus.Contracts.PoolForgery build-depends: base >= 4.9 && < 5, directory, diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/Data.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/Data.hs index 74310d6dd..ea6394e94 100644 --- a/AltLabs/dex-token-swap/src/Plutus/Contracts/Data.hs +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/Data.hs @@ -19,15 +19,43 @@ {-# LANGUAGE StandaloneDeriving #-} module Plutus.Contracts.Data where + -- ( + -- poolStateTokenName, + -- uniswapTokenName, + -- usCoin, + -- Coin, + -- Uniswap, Uniswapping, + -- UniswapDatum, + -- LiquidityPool, + -- CreateParams, + -- AddParams, + -- RemoveParams, + -- CloseParams, + -- SwapParams, + -- UniswapAction, + -- UserContractState, + -- ) where import Ledger import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf) import Playground.Contract (FromJSON, Generic, ToJSON, ToSchema) +import qualified Ledger.Typed.Scripts as Scripts import qualified PlutusTx import PlutusTx.Prelude hiding (Semigroup (..), unless) -import qualified Prelude as Haskell +import PlutusTx.Sqrt +import Prelude (Semigroup (..)) +import qualified Prelude import Text.Printf (PrintfArg) +uniswapTokenName, poolStateTokenName :: TokenName +-- state token for the "factory" (unique token) +-- "factory" is first created, this token gets minted +-- and put to the UTXO of the "factory" and stays there forever +uniswapTokenName = "Uniswap" + +-- state token of the liquidity pools (each pool has same token) +poolStateTokenName = "Pool State" + -- uniswapTokenName and poolStateTokenName share the same minting policy -- | A handy alias to put things in the language of "Coins" instead of -- "AssetClass". @@ -44,10 +72,92 @@ data LiquidityPool = LiquidityPool } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) -PlutusTx.unstableMakeIsData ''LiquidityPool -PlutusTx.makeLift ''LiquidityPool - instance Eq LiquidityPool where {-# INLINABLE (==) #-} x == y = (lpCoinA x == lpCoinA y && lpCoinB x == lpCoinB y) || - (lpCoinA x == lpCoinB y && lpCoinB x == lpCoinA y) \ No newline at end of file + (lpCoinA x == lpCoinB y && lpCoinB x == lpCoinA y) + +-- | Type of the Uniswap user contract state. +data UserContractState = + Pools [((Coin, Integer), (Coin, Integer))] + | Funds Value + | Created + | Swapped + | Added + | Removed + | Closed + | Stopped + deriving (Show, Generic, FromJSON, ToJSON) + +-- DATUM that each UTXO carries +-- +data UniswapDatum = + Factory [LiquidityPool] -- list of existing liquidity pools + | Pool LiquidityPool Integer -- Integer is the amount of tokens that have been minted for this LP + deriving stock (Show) + +-- Redeemer +-- possible actions AFTER the "factory" is setup +data UniswapAction = Create LiquidityPool | Close | Swap | Remove | Add + deriving Show + +-- just a wrapper around the "Coin" type (CurrencySymbol + TokenNAme) +newtype Uniswap = Uniswap + { usCoin :: Coin + } deriving stock (Show, Generic) + deriving anyclass (ToJSON, FromJSON, ToSchema) + deriving newtype (Prelude.Eq, Prelude.Ord) + +data Uniswapping +instance Scripts.ScriptType Uniswapping where + type instance RedeemerType Uniswapping = UniswapAction + type instance DatumType Uniswapping = UniswapDatum + +-- | Parameters for the @create@-endpoint, which creates a new liquidity pool. +data CreateParams = CreateParams + { cpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. + , cpCoinB :: Coin -- ^ The other 'Coin'. + , cpAmountA :: Integer -- ^ Amount of liquidity for the first 'Coin'. + , cpAmountB :: Integer -- ^ Amount of liquidity for the second 'Coin'. + } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) + +-- | Parameters for the @swap@-endpoint, which allows swaps between the two different coins in a liquidity pool. +-- One of the provided amounts must be positive, the other must be zero. +data SwapParams = SwapParams + { spCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. + , spCoinB :: Coin -- ^ The other 'Coin'. + , spAmountA :: Integer -- ^ The amount the first 'Coin' that should be swapped. + , spAmountB :: Integer -- ^ The amount of the second 'Coin' that should be swapped. + } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) + +-- | Parameters for the @close@-endpoint, which closes a liquidity pool. +data CloseParams = CloseParams + { clpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. + , clpCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. + } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) + +-- | Parameters for the @remove@-endpoint, which removes some liquidity from a liquidity pool. +data RemoveParams = RemoveParams + { rpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. + , rpCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. + , rpDiff :: Integer -- ^ The amount of liquidity tokens to burn in exchange for liquidity from the pool. + } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) + +-- | Parameters for the @add@-endpoint, which adds liquidity to a liquidity pool in exchange for liquidity tokens. +data AddParams = AddParams + { apCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. + , apCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. + , apAmountA :: Integer -- ^ The amount of coins of the first kind to add to the pool. + , apAmountB :: Integer -- ^ The amount of coins of the second kind to add to the pool. + } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) + +PlutusTx.unstableMakeIsData ''LiquidityPool +PlutusTx.makeLift ''LiquidityPool + +PlutusTx.makeLift ''Uniswap + +PlutusTx.unstableMakeIsData ''UniswapAction +PlutusTx.makeLift ''UniswapAction + +PlutusTx.unstableMakeIsData ''UniswapDatum +PlutusTx.makeLift ''UniswapDatum \ No newline at end of file diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/Helpers.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/Helpers.hs new file mode 100644 index 000000000..1b92504bc --- /dev/null +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/Helpers.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# options_ghc -fno-warn-orphans #-} + +-- | A decentralized exchange for arbitrary token pairs following the +-- [Uniswap protocol](https://uniswap.org/whitepaper.pdf). +-- +module Plutus.Contracts.Helpers + ( + poolStateCoin, + coinValueOf, + mkCoin, + findOwnInput, findOwnInput', + valueWithin, + liquidityPolicy, liquidityCurrency, + checkSwap, + coin, + findSwapA, findSwapB, + funds + ) where + +import Control.Monad hiding (fmap) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf, + symbols, unCurrencySymbol, unTokenName) +import Playground.Contract +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.Currency as Currency +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup (..), unless) +import PlutusTx.Sqrt +import Prelude (Semigroup (..)) +import qualified Prelude +import Text.Printf + +import Plutus.Contracts.Data +import Plutus.Contracts.LiquidityPool + +-- helper function to construct Values +-- Value (Cardano) is a "bag" of coins (1 ADA, 3 NFT etc...) +-- Dictionary of Dictionary of Int { CurrencySymbol: { TokenName: Int }} +{-# INLINABLE coin #-} +coin :: AssetClass -> Integer -> Value +coin = assetClassValue + +-- How many pieces of this Coin are contained in Value +{-# INLINABLE coinValueOf #-} +coinValueOf :: Value -> AssetClass -> Integer +coinValueOf = assetClassValueOf + +-- CurrencySymbol = hash of the pliutus script (which is run when you mint/burn token) +-- TokenName = bytestring (aka "Uniswap") +{-# INLINABLE mkCoin #-} +mkCoin:: CurrencySymbol -> TokenName -> AssetClass +mkCoin = assetClass + +{-# INLINABLE findOwnInput' #-} +findOwnInput' :: ScriptContext -> TxInInfo +findOwnInput' ctx = fromMaybe (error ()) (findOwnInput ctx) + +{-# INLINABLE valueWithin #-} +valueWithin :: TxInInfo -> Value +valueWithin = txOutValue . txInInfoResolved + + +-- GETTERS +-- | Gets the caller's funds. +funds :: HasBlockchainActions s => Contract w s Text Value +funds = do + pkh <- pubKeyHash <$> ownPubKey + os <- map snd . Map.toList <$> utxoAt (pubKeyHashAddress pkh) + return $ mconcat [txOutValue $ txOutTxOut o | o <- os] + +-- Checks if swap is possible +-- oldA, oldB = existing amount +-- newA, newB = amount after the swap +-- calculates that the product does NOT decrease +{-# INLINABLE checkSwap #-} +checkSwap :: Integer -> Integer -> Integer -> Integer -> Bool +checkSwap oldA oldB newA newB = + traceIfFalse "expected positive oldA" (oldA > 0) && + traceIfFalse "expected positive oldB" (oldB > 0) && + traceIfFalse "expected positive-newA" (newA > 0) && + traceIfFalse "expected positive-newB" (newB > 0) && + traceIfFalse "expected product to increase" + ((((newA * feeDen) - (inA * feeNum)) * ((newB * feeDen) - (inB * feeNum))) + >= (feeDen * feeDen * oldA * oldB)) + where + inA, inB :: Integer + inA = max 0 $ newA - oldA + inB = max 0 $ newB - oldB + -- The uniswap fee is 0.3%; here it is multiplied by 1000, so that the + -- on-chain code deals only in integers. + -- See: Eq (11) (Page 7.) + feeNum, feeDen :: Integer + feeNum = 3 + feeDen = 1000 + +findSwapA :: Integer -> Integer -> Integer -> Integer +findSwapA oldA oldB inA + | ub' <= 1 = 0 + | otherwise = go 1 ub' + where + cs :: Integer -> Bool + cs outB = checkSwap oldA oldB (oldA + inA) (oldB - outB) + + ub' :: Integer + ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] + + go :: Integer -> Integer -> Integer + go lb ub + | ub == (lb + 1) = lb + | otherwise = + let + m = div (ub + lb) 2 + in + if cs m then go m ub else go lb m + +findSwapB :: Integer -> Integer -> Integer -> Integer +findSwapB oldA oldB = findSwapA oldB oldA + +validateLiquidityForging :: Uniswap -> TokenName -> ScriptContext -> Bool +validateLiquidityForging us tn ctx = case [ i + | i <- txInfoInputs $ scriptContextTxInfo ctx + , let v = valueWithin i + , (coinValueOf v usC == 1) || + (coinValueOf v lpC == 1) + ] of + [_] -> True + [_, _] -> True + _ -> traceError "pool state forging without Uniswap input" + where + usC, lpC :: Coin + usC = usCoin us + lpC = mkCoin (ownCurrencySymbol ctx) tn + +liquidityPolicy :: Uniswap -> MonetaryPolicy +liquidityPolicy us = mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| \u t -> Scripts.wrapMonetaryPolicy (validateLiquidityForging u t) ||]) + `PlutusTx.applyCode` PlutusTx.liftCode us + `PlutusTx.applyCode` PlutusTx.liftCode poolStateTokenName + +liquidityCurrency :: Uniswap -> CurrencySymbol +liquidityCurrency = scriptCurrencySymbol . liquidityPolicy + +poolStateCoin :: Uniswap -> Coin +poolStateCoin = flip mkCoin poolStateTokenName . liquidityCurrency + +-- uniswapInstance :: Uniswap -> Scripts.ScriptInstance Uniswapping +-- uniswapInstance us = Scripts.validator @Uniswapping +-- ($$(PlutusTx.compile [|| mkUniswapValidator ||]) +-- `PlutusTx.applyCode` PlutusTx.liftCode us +-- `PlutusTx.applyCode` PlutusTx.liftCode c) +-- $$(PlutusTx.compile [|| wrap ||]) +-- where +-- c :: Coin +-- c = poolStateCoin us + +-- wrap = Scripts.wrapValidator @UniswapDatum @UniswapAction + +-- uniswapScript :: Uniswap -> Validator +-- uniswapScript = Scripts.validatorScript . uniswapInstance diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/LiquidityPool.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/LiquidityPool.hs index be9db6a71..0e1716b9d 100644 --- a/AltLabs/dex-token-swap/src/Plutus/Contracts/LiquidityPool.hs +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/LiquidityPool.hs @@ -6,9 +6,6 @@ module Plutus.Contracts.LiquidityPool ( calculateAdditionalLiquidity , calculateInitialLiquidity , calculateRemoval - -- , checkSwap - -- , lpTicker - , LiquidityPool ) where import Ledger.Value (TokenName (..), unAssetClass, unCurrencySymbol) diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/PoolForgery.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/PoolForgery.hs new file mode 100644 index 000000000..428e8e7cc --- /dev/null +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/PoolForgery.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# options_ghc -fno-warn-orphans #-} + +module Plutus.Contracts.PoolForgery( + create, + close +) where + +import Control.Monad hiding (fmap) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf, + symbols, unCurrencySymbol, unTokenName) +import Playground.Contract +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.Currency as Currency +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup (..), unless) +import PlutusTx.Sqrt +import Prelude (Semigroup (..)) +import qualified Prelude +import Text.Printf (printf) +import Plutus.Contracts.Data +import Plutus.Contracts.Helpers +import Plutus.Contracts.Validators +-- import Plutus.Contracts.UniswapHelpers +import Plutus.Contracts.LiquidityPool + +-- | Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. +-- Each Liquidity pool creates another UTXO with a different token from the factory (state token) +-- each time a pool is created a new token is minted +-- CurrencySymbol uniquely identifies this "factory", sits at the specific address +create :: HasBlockchainActions s => Uniswap -> CreateParams -> Contract w s Text () +create us CreateParams{..} = do + when (cpCoinA == cpCoinB) $ throwError "coins must be different" + when (cpAmountA <= 0 || cpAmountB <= 0) $ throwError "amounts must be positive" + (oref, o, lps) <- findUniswapFactory us + let liquidity = calculateInitialLiquidity cpAmountA cpAmountB + lp = LiquidityPool {lpCoinA = cpCoinA, lpCoinB = cpCoinB} + let usInst = uniswapInstance us + usScript = uniswapScript us + usDat1 = Factory $ lp : lps + usDat2 = Pool lp liquidity + psC = poolStateCoin us + lC = mkCoin (liquidityCurrency us) $ lpTicker lp + usVal = coin (usCoin us) 1 + lpVal = coin cpCoinA cpAmountA <> coin cpCoinB cpAmountB <> coin psC 1 + + lookups = Constraints.scriptInstanceLookups usInst <> + Constraints.otherScript usScript <> + Constraints.monetaryPolicy (liquidityPolicy us) <> + Constraints.unspentOutputs (Map.singleton oref o) + + tx = Constraints.mustPayToTheScript usDat1 usVal <> + Constraints.mustPayToTheScript usDat2 lpVal <> + Constraints.mustForgeValue (coin psC 1 <> coin lC liquidity) <> + Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Create lp) + + ledgerTx <- submitTxConstraintsWith lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + + logInfo $ "created liquidity pool: " ++ show lp + +-- | Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. +close :: HasBlockchainActions s => Uniswap -> CloseParams -> Contract w s Text () +close us CloseParams{..} = do + ((oref1, o1, lps), (oref2, o2, lp, liquidity)) <- findUniswapFactoryAndPool us clpCoinA clpCoinB + pkh <- pubKeyHash <$> ownPubKey + let usInst = uniswapInstance us + usScript = uniswapScript us + usDat = Factory $ filter (/= lp) lps + usC = usCoin us + psC = poolStateCoin us + lC = mkCoin (liquidityCurrency us) $ lpTicker lp + usVal = coin usC 1 + psVal = coin psC 1 + lVal = coin lC liquidity + redeemer = Redeemer $ PlutusTx.toData Close + + lookups = Constraints.scriptInstanceLookups usInst <> + Constraints.otherScript usScript <> + Constraints.monetaryPolicy (liquidityPolicy us) <> + Constraints.ownPubKeyHash pkh <> + Constraints.unspentOutputs (Map.singleton oref1 o1 <> Map.singleton oref2 o2) + + tx = Constraints.mustPayToTheScript usDat usVal <> + Constraints.mustForgeValue (negate $ psVal <> lVal) <> + Constraints.mustSpendScriptOutput oref1 redeemer <> + Constraints.mustSpendScriptOutput oref2 redeemer <> + Constraints.mustIncludeDatum (Datum $ PlutusTx.toData $ Pool lp liquidity) + + ledgerTx <- submitTxConstraintsWith lookups tx + void $ awaitTxConfirmed $ txId ledgerTx + + logInfo $ "closed liquidity pool: " ++ show lp \ No newline at end of file diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/Uniswap.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/Uniswap.hs index 8439f4ee2..c32518ab6 100644 --- a/AltLabs/dex-token-swap/src/Plutus/Contracts/Uniswap.hs +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/Uniswap.hs @@ -24,12 +24,6 @@ module Plutus.Contracts.Uniswap ( coin, coinValueOf, mkCoin , Uniswap (..), uniswap - , poolStateCoinFromUniswapCurrency, liquidityCoin - , CreateParams (..) - , SwapParams (..) - , CloseParams (..) - , RemoveParams (..) - , AddParams (..) , UniswapUserSchema, UserContractState (..) , UniswapOwnerSchema , start, create, add, remove, close, swap, pools @@ -60,444 +54,12 @@ import Prelude (Semigroup (..)) import qualified Prelude import Text.Printf (printf) import Plutus.Contracts.Data +-- import Plutus.Contracts.UniswapHelpers +import Plutus.Contracts.Helpers +import Plutus.Contracts.Validators import Plutus.Contracts.LiquidityPool +import Plutus.Contracts.PoolForgery (create, close) -uniswapTokenName, poolStateTokenName :: TokenName --- state token for the "factory" (unique token) --- "factory" is first created, this token gets minted --- and put to the UTXO of the "factory" and stays there forever -uniswapTokenName = "Uniswap" - --- state token of the liquidity pools (each pool has same token) -poolStateTokenName = "Pool State" - --- helper function to construct Values --- Value (Cardano) is a "bag" of coins (1 ADA, 3 NFT etc...) --- Dictionary of Dictionary of Int { CurrencySymbol: { TokenName: Int }} -{-# INLINABLE coin #-} -coin :: AssetClass -> Integer -> Value -coin = assetClassValue - --- How many pieces of this Coin are contained in Value -{-# INLINABLE coinValueOf #-} -coinValueOf :: Value -> AssetClass -> Integer -coinValueOf = assetClassValueOf - --- CurrencySymbol = hash of the pliutus script (which is run when you mint/burn token) --- TokenName = bytestring (aka "Uniswap") -{-# INLINABLE mkCoin #-} -mkCoin:: CurrencySymbol -> TokenName -> AssetClass -mkCoin = assetClass - --- just a wrapper around the "Coin" type (CurrencySymbol + TokenNAme) -newtype Uniswap = Uniswap - { usCoin :: Coin - } deriving stock (Show, Generic) - deriving anyclass (ToJSON, FromJSON, ToSchema) - deriving newtype (Prelude.Eq, Prelude.Ord) - -PlutusTx.makeLift ''Uniswap - --- Redeemer --- possible actions AFTER the "factory" is setup -data UniswapAction = Create LiquidityPool | Close | Swap | Remove | Add - deriving Show - -PlutusTx.unstableMakeIsData ''UniswapAction -PlutusTx.makeLift ''UniswapAction - --- DATUM that each UTXO carries --- -data UniswapDatum = - Factory [LiquidityPool] -- list of existing liquidity pools - | Pool LiquidityPool Integer -- Integer is the amount of tokens that have been minted for this LP - deriving stock (Show) - -PlutusTx.unstableMakeIsData ''UniswapDatum -PlutusTx.makeLift ''UniswapDatum - -data Uniswapping -instance Scripts.ScriptType Uniswapping where - type instance RedeemerType Uniswapping = UniswapAction - type instance DatumType Uniswapping = UniswapDatum - - -{-# INLINABLE findOwnInput' #-} -findOwnInput' :: ScriptContext -> TxInInfo -findOwnInput' ctx = fromMaybe (error ()) (findOwnInput ctx) - -{-# INLINABLE valueWithin #-} -valueWithin :: TxInInfo -> Value -valueWithin = txOutValue . txInInfoResolved - --- Checks if swap is possible --- oldA, oldB = existing amount --- newA, newB = amount after the swap --- calculates that the product does NOT decrease -{-# INLINABLE checkSwap #-} -checkSwap :: Integer -> Integer -> Integer -> Integer -> Bool -checkSwap oldA oldB newA newB = - traceIfFalse "expected positive oldA" (oldA > 0) && - traceIfFalse "expected positive oldB" (oldB > 0) && - traceIfFalse "expected positive-newA" (newA > 0) && - traceIfFalse "expected positive-newB" (newB > 0) && - traceIfFalse "expected product to increase" - ((((newA * feeDen) - (inA * feeNum)) * ((newB * feeDen) - (inB * feeNum))) - >= (feeDen * feeDen * oldA * oldB)) - where - inA, inB :: Integer - inA = max 0 $ newA - oldA - inB = max 0 $ newB - oldB - -- The uniswap fee is 0.3%; here it is multiplied by 1000, so that the - -- on-chain code deals only in integers. - -- See: Eq (11) (Page 7.) - feeNum, feeDen :: Integer - feeNum = 3 - feeDen = 1000 - --- LiquidityPool = UTXO we consume --- Coin = pool state coin that must be there --- 1 of output(s) = new state of the pool --- must make sure the amounts of liqudity pool are correct -{-# INLINABLE validateSwap #-} -validateSwap :: LiquidityPool -> Coin -> ScriptContext -> Bool -validateSwap LiquidityPool{..} c ctx = - - checkSwap oldA oldB newA newB -- first check products and fees - && - traceIfFalse "expected pool state token to be present in input" (coinValueOf inVal c == 1) && -- identify that we are dealing with the right UTXO (by means of a token) - traceIfFalse "expected pool state token to be present in output" (coinValueOf outVal c == 1) && - traceIfFalse "did not expect Uniswap forging" noUniswapForging - where - info :: TxInfo - info = scriptContextTxInfo ctx - - ownInput :: TxInInfo - ownInput = findOwnInput' ctx - - ownOutput :: TxOut - ownOutput = case [ o - | o <- getContinuingOutputs ctx - , txOutDatumHash o == Just (snd $ ownHashes ctx) - ] of - [o] -> o - _ -> traceError "expected exactly one output to the same liquidity pool" - - oldA, oldB, newA, newB :: Integer - oldA = amountA inVal - oldB = amountB inVal - newA = amountA outVal - newB = amountB outVal - - amountA, amountB :: Value -> Integer - amountA v = coinValueOf v lpCoinA - amountB v = coinValueOf v lpCoinB - - inVal, outVal :: Value - inVal = valueWithin ownInput - outVal = txOutValue ownOutput - - noUniswapForging :: Bool - noUniswapForging = - let - AssetClass (cs, _) = c - forged = txInfoForge info - in - all (/= cs) $ symbols forged - -{-# INLINABLE validateCreate #-} -validateCreate :: Uniswap - -> Coin - -> [LiquidityPool] - -> LiquidityPool - -> ScriptContext - -> Bool -validateCreate Uniswap{..} c lps lp@LiquidityPool{..} ctx = - traceIfFalse "Uniswap coin not present" (coinValueOf (valueWithin $ findOwnInput' ctx) usCoin == 1) && - (lpCoinA /= lpCoinB) && - all (/= lp) lps && - Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Factory $ lp : lps) $ coin usCoin 1) && - (coinValueOf forged c == 1) && - (coinValueOf forged liquidityCoin' == liquidity) && - (outA > 0) && - (outB > 0) && - Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Pool lp liquidity) $ - coin lpCoinA outA <> coin lpCoinB outB <> coin c 1) - where - poolOutput :: TxOut - poolOutput = case [o | o <- getContinuingOutputs ctx, coinValueOf (txOutValue o) c == 1] of - [o] -> o - _ -> traceError "expected exactly one pool output" - - outA, outB, liquidity :: Integer - outA = coinValueOf (txOutValue poolOutput) lpCoinA - outB = coinValueOf (txOutValue poolOutput) lpCoinB - liquidity = calculateInitialLiquidity outA outB - - forged :: Value - forged = txInfoForge $ scriptContextTxInfo ctx - - liquidityCoin' :: Coin - liquidityCoin' = let AssetClass (cs,_) = c in mkCoin cs $ lpTicker lp - -{-# INLINABLE validateCloseFactory #-} -validateCloseFactory :: Uniswap -> Coin -> [LiquidityPool] -> ScriptContext -> Bool -validateCloseFactory us c lps ctx = - traceIfFalse "Uniswap coin not present" (coinValueOf (valueWithin $ findOwnInput' ctx) usC == 1) && - traceIfFalse "wrong forge value" (txInfoForge info == negate (coin c 1 <> coin lC (snd lpLiquidity))) && - traceIfFalse "factory output wrong" - (Constraints.checkOwnOutputConstraint ctx $ OutputConstraint (Factory $ filter (/= fst lpLiquidity) lps) $ coin usC 1) - where - info :: TxInfo - info = scriptContextTxInfo ctx - - poolInput :: TxInInfo - poolInput = case [ i - | i <- txInfoInputs info - , coinValueOf (valueWithin i) c == 1 - ] of - [i] -> i - _ -> traceError "expected exactly one pool input" - - lpLiquidity :: (LiquidityPool, Integer) - lpLiquidity = case txOutDatumHash . txInInfoResolved $ poolInput of - Nothing -> traceError "pool input witness missing" - Just h -> findPoolDatum info h - - lC, usC :: Coin - lC = let AssetClass (cs, _) = c in mkCoin cs (lpTicker $ fst lpLiquidity) - usC = usCoin us - -{-# INLINABLE validateClosePool #-} -validateClosePool :: Uniswap -> ScriptContext -> Bool -validateClosePool us ctx = hasFactoryInput - where - info :: TxInfo - info = scriptContextTxInfo ctx - - hasFactoryInput :: Bool - hasFactoryInput = - traceIfFalse "Uniswap factory input expected" $ - coinValueOf (valueSpent info) (usCoin us) == 1 - -{-# INLINABLE validateRemove #-} -validateRemove :: Coin -> LiquidityPool -> Integer -> ScriptContext -> Bool -validateRemove c lp liquidity ctx = - traceIfFalse "zero removal" (diff > 0) && - traceIfFalse "removal of too much liquidity" (diff < liquidity) && - traceIfFalse "pool state coin missing" (coinValueOf inVal c == 1) && - traceIfFalse "wrong liquidity pool output" (fst lpLiquidity == lp) && - traceIfFalse "pool state coin missing from output" (coinValueOf outVal c == 1) && - traceIfFalse "liquidity tokens not burnt" (txInfoForge info == negate (coin lC diff)) && - traceIfFalse "non-positive liquidity" (outA > 0 && outB > 0) - where - info :: TxInfo - info = scriptContextTxInfo ctx - - ownInput :: TxInInfo - ownInput = findOwnInput' ctx - - output :: TxOut - output = case getContinuingOutputs ctx of - [o] -> o - _ -> traceError "expected exactly one Uniswap output" - - inVal, outVal :: Value - inVal = valueWithin ownInput - outVal = txOutValue output - - lpLiquidity :: (LiquidityPool, Integer) - lpLiquidity = case txOutDatumHash output of - Nothing -> traceError "pool output witness missing" - Just h -> findPoolDatum info h - - lC :: Coin - lC = let AssetClass (cs, _) = c in mkCoin cs (lpTicker lp) - - diff, inA, inB, outA, outB :: Integer - diff = liquidity - snd lpLiquidity - inA = coinValueOf inVal $ lpCoinA lp - inB = coinValueOf inVal $ lpCoinB lp - (outA, outB) = calculateRemoval inA inB liquidity diff - -{-# INLINABLE validateAdd #-} -validateAdd :: Coin -> LiquidityPool -> Integer -> ScriptContext -> Bool -validateAdd c lp liquidity ctx = - traceIfFalse "pool stake token missing from input" (coinValueOf inVal c == 1) && - traceIfFalse "output pool for same liquidity pair expected" (lp == fst outDatum) && - traceIfFalse "must not remove tokens" (delA >= 0 && delB >= 0) && - traceIfFalse "insufficient liquidity" (delL >= 0) && - traceIfFalse "wrong amount of liquidity tokens" (delL == calculateAdditionalLiquidity oldA oldB liquidity delA delB) && - traceIfFalse "wrong amount of liquidity tokens forged" (txInfoForge info == coin lC delL) - where - info :: TxInfo - info = scriptContextTxInfo ctx - - ownInput :: TxInInfo - ownInput = findOwnInput' ctx - - ownOutput :: TxOut - ownOutput = case [ o - | o <- getContinuingOutputs ctx - , coinValueOf (txOutValue o) c == 1 - ] of - [o] -> o - _ -> traceError "expected exactly on pool output" - - outDatum :: (LiquidityPool, Integer) - outDatum = case txOutDatum ownOutput of - Nothing -> traceError "pool output datum hash not found" - Just h -> findPoolDatum info h - - inVal, outVal :: Value - inVal = valueWithin ownInput - outVal = txOutValue ownOutput - - oldA, oldB, delA, delB, delL :: Integer - oldA = coinValueOf inVal aC - oldB = coinValueOf inVal bC - delA = coinValueOf outVal aC - oldA - delB = coinValueOf outVal bC - oldB - delL = snd outDatum - liquidity - - aC, bC, lC :: Coin - aC = lpCoinA lp - bC = lpCoinB lp - lC = let AssetClass (cs, _) = c in mkCoin cs $ lpTicker lp - -{-# INLINABLE findPoolDatum #-} -findPoolDatum :: TxInfo -> DatumHash -> (LiquidityPool, Integer) -findPoolDatum info h = case findDatum h info of - Just (Datum d) -> case PlutusTx.fromData d of - Just (Pool lp a) -> (lp, a) - _ -> traceError "error decoding data" - _ -> traceError "pool input datum not found" - -{-# INLINABLE lpTicker #-} -lpTicker :: LiquidityPool -> TokenName -lpTicker LiquidityPool{..} = TokenName $ - unCurrencySymbol (c_cs) `concatenate` - unCurrencySymbol (d_cs) `concatenate` - unTokenName (c_tok) `concatenate` - unTokenName (d_tok) - where - (AssetClass (c_cs, c_tok), AssetClass (d_cs, d_tok)) - | lpCoinA < lpCoinB = (lpCoinA, lpCoinB) - | otherwise = (lpCoinB, lpCoinA) - --- the actual Validator --- basically a sub-function switch -mkUniswapValidator :: Uniswap - -> Coin - -> UniswapDatum - -> UniswapAction - -> ScriptContext - -> Bool -mkUniswapValidator us c (Factory lps) (Create lp) ctx = validateCreate us c lps lp ctx -mkUniswapValidator _ c (Pool lp _) Swap ctx = validateSwap lp c ctx -mkUniswapValidator us c (Factory lps) Close ctx = validateCloseFactory us c lps ctx -mkUniswapValidator us _ (Pool _ _) Close ctx = validateClosePool us ctx -mkUniswapValidator _ c (Pool lp a) Remove ctx = validateRemove c lp a ctx -mkUniswapValidator _ c (Pool lp a) Add ctx = validateAdd c lp a ctx -mkUniswapValidator _ _ _ _ _ = False - -validateLiquidityForging :: Uniswap -> TokenName -> ScriptContext -> Bool -validateLiquidityForging us tn ctx = case [ i - | i <- txInfoInputs $ scriptContextTxInfo ctx - , let v = valueWithin i - , (coinValueOf v usC == 1) || - (coinValueOf v lpC == 1) - ] of - [_] -> True - [_, _] -> True - _ -> traceError "pool state forging without Uniswap input" - where - usC, lpC :: Coin - usC = usCoin us - lpC = mkCoin (ownCurrencySymbol ctx) tn - -uniswapInstance :: Uniswap -> Scripts.ScriptInstance Uniswapping -uniswapInstance us = Scripts.validator @Uniswapping - ($$(PlutusTx.compile [|| mkUniswapValidator ||]) - `PlutusTx.applyCode` PlutusTx.liftCode us - `PlutusTx.applyCode` PlutusTx.liftCode c) - $$(PlutusTx.compile [|| wrap ||]) - where - c :: Coin - c = poolStateCoin us - - wrap = Scripts.wrapValidator @UniswapDatum @UniswapAction - -uniswapScript :: Uniswap -> Validator -uniswapScript = Scripts.validatorScript . uniswapInstance - -uniswapAddress :: Uniswap -> Ledger.Address -uniswapAddress = Ledger.scriptAddress . uniswapScript - -uniswap :: CurrencySymbol -> Uniswap -uniswap cs = Uniswap $ mkCoin cs uniswapTokenName - -liquidityPolicy :: Uniswap -> MonetaryPolicy -liquidityPolicy us = mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| \u t -> Scripts.wrapMonetaryPolicy (validateLiquidityForging u t) ||]) - `PlutusTx.applyCode` PlutusTx.liftCode us - `PlutusTx.applyCode` PlutusTx.liftCode poolStateTokenName - -liquidityCurrency :: Uniswap -> CurrencySymbol -liquidityCurrency = scriptCurrencySymbol . liquidityPolicy - -poolStateCoin :: Uniswap -> Coin -poolStateCoin = flip mkCoin poolStateTokenName . liquidityCurrency - --- | Gets the 'Coin' used to identity liquidity pools. -poolStateCoinFromUniswapCurrency :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. - -> Coin -poolStateCoinFromUniswapCurrency = poolStateCoin . uniswap - --- | Gets the liquidity token for a given liquidity pool. -liquidityCoin :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. - -> Coin -- ^ One coin in the liquidity pair. - -> Coin -- ^ The other coin in the liquidity pair. - -> Coin -liquidityCoin cs coinA coinB = mkCoin (liquidityCurrency $ uniswap cs) $ lpTicker $ LiquidityPool coinA coinB - --- | Parameters for the @create@-endpoint, which creates a new liquidity pool. -data CreateParams = CreateParams - { cpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. - , cpCoinB :: Coin -- ^ The other 'Coin'. - , cpAmountA :: Integer -- ^ Amount of liquidity for the first 'Coin'. - , cpAmountB :: Integer -- ^ Amount of liquidity for the second 'Coin'. - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) - --- | Parameters for the @swap@-endpoint, which allows swaps between the two different coins in a liquidity pool. --- One of the provided amounts must be positive, the other must be zero. -data SwapParams = SwapParams - { spCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. - , spCoinB :: Coin -- ^ The other 'Coin'. - , spAmountA :: Integer -- ^ The amount the first 'Coin' that should be swapped. - , spAmountB :: Integer -- ^ The amount of the second 'Coin' that should be swapped. - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) - --- | Parameters for the @close@-endpoint, which closes a liquidity pool. -data CloseParams = CloseParams - { clpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. - , clpCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) - --- | Parameters for the @remove@-endpoint, which removes some liquidity from a liquidity pool. -data RemoveParams = RemoveParams - { rpCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. - , rpCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. - , rpDiff :: Integer -- ^ The amount of liquidity tokens to burn in exchange for liquidity from the pool. - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) - --- | Parameters for the @add@-endpoint, which adds liquidity to a liquidity pool in exchange for liquidity tokens. -data AddParams = AddParams - { apCoinA :: Coin -- ^ One 'Coin' of the liquidity pair. - , apCoinB :: Coin -- ^ The other 'Coin' of the liquidity pair. - , apAmountA :: Integer -- ^ The amount of coins of the first kind to add to the pool. - , apAmountB :: Integer -- ^ The amount of coins of the second kind to add to the pool. - } deriving (Show, Generic, ToJSON, FromJSON, ToSchema) -- | 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 -- for any pair of tokens at any given time. @@ -520,74 +82,6 @@ start = do logInfo @String $ printf "started Uniswap %s at address %s" (show us) (show $ uniswapAddress us) return us --- | Creates a liquidity pool for a pair of coins. The creator provides liquidity for both coins and gets liquidity tokens in return. --- Each Liquidity pool creates another UTXO with a different token from the factory (state token) --- each time a pool is created a new token is minted --- CurrencySymbol uniquely identifies this "factory", sits at the specific address -create :: HasBlockchainActions s => Uniswap -> CreateParams -> Contract w s Text () -create us CreateParams{..} = do - when (cpCoinA == cpCoinB) $ throwError "coins must be different" - when (cpAmountA <= 0 || cpAmountB <= 0) $ throwError "amounts must be positive" - (oref, o, lps) <- findUniswapFactory us - let liquidity = calculateInitialLiquidity cpAmountA cpAmountB - lp = LiquidityPool {lpCoinA = cpCoinA, lpCoinB = cpCoinB} - let usInst = uniswapInstance us - usScript = uniswapScript us - usDat1 = Factory $ lp : lps - usDat2 = Pool lp liquidity - psC = poolStateCoin us - lC = mkCoin (liquidityCurrency us) $ lpTicker lp - usVal = coin (usCoin us) 1 - lpVal = coin cpCoinA cpAmountA <> coin cpCoinB cpAmountB <> coin psC 1 - - lookups = Constraints.scriptInstanceLookups usInst <> - Constraints.otherScript usScript <> - Constraints.monetaryPolicy (liquidityPolicy us) <> - Constraints.unspentOutputs (Map.singleton oref o) - - tx = Constraints.mustPayToTheScript usDat1 usVal <> - Constraints.mustPayToTheScript usDat2 lpVal <> - Constraints.mustForgeValue (coin psC 1 <> coin lC liquidity) <> - Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Create lp) - - ledgerTx <- submitTxConstraintsWith lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - - logInfo $ "created liquidity pool: " ++ show lp - --- | Closes a liquidity pool by burning all remaining liquidity tokens in exchange for all liquidity remaining in the pool. -close :: HasBlockchainActions s => Uniswap -> CloseParams -> Contract w s Text () -close us CloseParams{..} = do - ((oref1, o1, lps), (oref2, o2, lp, liquidity)) <- findUniswapFactoryAndPool us clpCoinA clpCoinB - pkh <- pubKeyHash <$> ownPubKey - let usInst = uniswapInstance us - usScript = uniswapScript us - usDat = Factory $ filter (/= lp) lps - usC = usCoin us - psC = poolStateCoin us - lC = mkCoin (liquidityCurrency us) $ lpTicker lp - usVal = coin usC 1 - psVal = coin psC 1 - lVal = coin lC liquidity - redeemer = Redeemer $ PlutusTx.toData Close - - lookups = Constraints.scriptInstanceLookups usInst <> - Constraints.otherScript usScript <> - Constraints.monetaryPolicy (liquidityPolicy us) <> - Constraints.ownPubKeyHash pkh <> - Constraints.unspentOutputs (Map.singleton oref1 o1 <> Map.singleton oref2 o2) - - tx = Constraints.mustPayToTheScript usDat usVal <> - Constraints.mustForgeValue (negate $ psVal <> lVal) <> - Constraints.mustSpendScriptOutput oref1 redeemer <> - Constraints.mustSpendScriptOutput oref2 redeemer <> - Constraints.mustIncludeDatum (Datum $ PlutusTx.toData $ Pool lp liquidity) - - ledgerTx <- submitTxConstraintsWith lookups tx - void $ awaitTxConfirmed $ txId ledgerTx - - logInfo $ "closed liquidity pool: " ++ show lp - -- | Removes some liquidity from a liquidity pool in exchange for liquidity tokens. remove :: HasBlockchainActions s => Uniswap -> RemoveParams -> Contract w s Text () remove us RemoveParams{..} = do @@ -735,92 +229,6 @@ pools us = do where c :: Coin c = poolStateCoin us --- --- | Gets the caller's funds. -funds :: HasBlockchainActions s => Contract w s Text Value -funds = do - pkh <- pubKeyHash <$> ownPubKey - os <- map snd . Map.toList <$> utxoAt (pubKeyHashAddress pkh) - return $ mconcat [txOutValue $ txOutTxOut o | o <- os] - -getUniswapDatum :: TxOutTx -> Contract w s Text UniswapDatum -getUniswapDatum o = case txOutDatumHash $ txOutTxOut o of - Nothing -> throwError "datumHash not found" - Just h -> case Map.lookup h $ txData $ txOutTxTx o of - Nothing -> throwError "datum not found" - Just (Datum e) -> case PlutusTx.fromData e of - Nothing -> throwError "datum has wrong type" - Just d -> return d - -findUniswapInstance :: HasBlockchainActions s => Uniswap -> Coin -> (UniswapDatum -> Maybe a) -> Contract w s Text (TxOutRef, TxOutTx, a) -findUniswapInstance us c f = do - let addr = uniswapAddress us - logInfo @String $ printf "looking for Uniswap instance at address %s containing coin %s " (show addr) (show c) - utxos <- utxoAt addr - go [x | x@(_, o) <- Map.toList utxos, coinValueOf (txOutValue $ txOutTxOut o) c == 1] - where - go [] = throwError "Uniswap instance not found" - go ((oref, o) : xs) = do - d <- getUniswapDatum o - case f d of - Nothing -> go xs - Just a -> do - logInfo @String $ printf "found Uniswap instance with datum: %s" (show d) - return (oref, o, a) - -findUniswapFactory :: HasBlockchainActions s => Uniswap -> Contract w s Text (TxOutRef, TxOutTx, [LiquidityPool]) -findUniswapFactory us@Uniswap{..} = findUniswapInstance us usCoin $ \case - Factory lps -> Just lps - Pool _ _ -> Nothing - -findUniswapPool :: HasBlockchainActions s => Uniswap -> LiquidityPool -> Contract w s Text (TxOutRef, TxOutTx, Integer) -findUniswapPool us lp = findUniswapInstance us (poolStateCoin us) $ \case - Pool lp' l - | lp == lp' -> Just l - _ -> Nothing - -findUniswapFactoryAndPool :: HasBlockchainActions s - => Uniswap - -> Coin - -> Coin - -> Contract w s Text ( (TxOutRef, TxOutTx, [LiquidityPool]) - , (TxOutRef, TxOutTx, LiquidityPool, Integer) - ) -findUniswapFactoryAndPool us coinA coinB = do - (oref1, o1, lps) <- findUniswapFactory us - case [ lp' - | lp' <- lps - , lp' == LiquidityPool coinA coinB - ] of - [lp] -> do - (oref2, o2, a) <- findUniswapPool us lp - return ( (oref1, o1, lps) - , (oref2, o2, lp, a) - ) - _ -> throwError "liquidity pool not found" - -findSwapA :: Integer -> Integer -> Integer -> Integer -findSwapA oldA oldB inA - | ub' <= 1 = 0 - | otherwise = go 1 ub' - where - cs :: Integer -> Bool - cs outB = checkSwap oldA oldB (oldA + inA) (oldB - outB) - - ub' :: Integer - ub' = head $ dropWhile cs [2 ^ i | i <- [0 :: Int ..]] - - go :: Integer -> Integer -> Integer - go lb ub - | ub == (lb + 1) = lb - | otherwise = - let - m = div (ub + lb) 2 - in - if cs m then go m ub else go lb m - -findSwapB :: Integer -> Integer -> Integer -> Integer -findSwapB oldA oldB = findSwapA oldB oldA ownerEndpoint :: Contract (Last (Either Text Uniswap)) BlockchainActions Void () ownerEndpoint = do @@ -845,17 +253,7 @@ type UniswapUserSchema = .\/ Endpoint "funds" () .\/ Endpoint "stop" () --- | Type of the Uniswap user contract state. -data UserContractState = - Pools [((Coin, Integer), (Coin, Integer))] - | Funds Value - | Created - | Swapped - | Added - | Removed - | Closed - | Stopped - deriving (Show, Generic, FromJSON, ToJSON) + -- | Provides the following endpoints for users of a Uniswap instance: -- diff --git a/AltLabs/dex-token-swap/src/Plutus/Contracts/Validators.hs b/AltLabs/dex-token-swap/src/Plutus/Contracts/Validators.hs new file mode 100644 index 000000000..acf26ab07 --- /dev/null +++ b/AltLabs/dex-token-swap/src/Plutus/Contracts/Validators.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# options_ghc -fno-warn-orphans #-} + +-- | A decentralized exchange for arbitrary token pairs following the +-- [Uniswap protocol](https://uniswap.org/whitepaper.pdf). +-- +module Plutus.Contracts.Validators + ( + validateCreate, + validateSwap, + validateCloseFactory, + validateClosePool, + validateRemove, + validateAdd, + + lpTicker, + mkUniswapValidator, + uniswap, + uniswapInstance, + findPoolDatum, + uniswapAddress, + getUniswapDatum,findUniswapFactory, findUniswapFactoryAndPool, findUniswapInstance, findUniswapPool, + liquidityCoin, + uniswapScript + ) where + +import Control.Monad hiding (fmap) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value (AssetClass (..), assetClass, assetClassValue, assetClassValueOf, + symbols, unCurrencySymbol, unTokenName) +import Playground.Contract +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.Currency as Currency +import qualified PlutusTx +import PlutusTx.Prelude hiding (Semigroup (..), unless) +import PlutusTx.Sqrt +import Prelude (Semigroup (..)) +import qualified Prelude +import Text.Printf + +import Plutus.Contracts.Data +import Plutus.Contracts.Helpers +-- import Plutus.Contracts.UniswapHelpers +import Plutus.Contracts.LiquidityPool + + +-- LiquidityPool = UTXO we consume +-- Coin = pool state coin that must be there +-- 1 of output(s) = new state of the pool +-- must make sure the amounts of liqudity pool are correct +{-# INLINABLE validateSwap #-} +validateSwap :: LiquidityPool -> Coin -> ScriptContext -> Bool +validateSwap LiquidityPool{..} c ctx = + + checkSwap oldA oldB newA newB -- first check products and fees + && + traceIfFalse "expected pool state token to be present in input" (coinValueOf inVal c == 1) && -- identify that we are dealing with the right UTXO (by means of a token) + traceIfFalse "expected pool state token to be present in output" (coinValueOf outVal c == 1) && + traceIfFalse "did not expect Uniswap forging" noUniswapForging + where + info :: TxInfo + info = scriptContextTxInfo ctx + + ownInput :: TxInInfo + ownInput = findOwnInput' ctx + + ownOutput :: TxOut + ownOutput = case [ o + | o <- getContinuingOutputs ctx + , txOutDatumHash o == Just (snd $ ownHashes ctx) + ] of + [o] -> o + _ -> traceError "expected exactly one output to the same liquidity pool" + + oldA, oldB, newA, newB :: Integer + oldA = amountA inVal + oldB = amountB inVal + newA = amountA outVal + newB = amountB outVal + + amountA, amountB :: Value -> Integer + amountA v = coinValueOf v lpCoinA + amountB v = coinValueOf v lpCoinB + + inVal, outVal :: Value + inVal = valueWithin ownInput + outVal = txOutValue ownOutput + + noUniswapForging :: Bool + noUniswapForging = + let + AssetClass (cs, _) = c + forged = txInfoForge info + in + notElem cs $ symbols forged + +{-# INLINABLE validateCreate #-} +validateCreate :: Uniswap + -> Coin + -> [LiquidityPool] + -> LiquidityPool + -> ScriptContext + -> Bool +validateCreate Uniswap{..} c lps lp@LiquidityPool{..} ctx = + traceIfFalse "Uniswap coin not present" (coinValueOf (valueWithin $ findOwnInput' ctx) usCoin == 1) && + lpCoinA /= lpCoinB && + notElem lp lps && + Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Factory $ lp : lps) $ coin usCoin 1) && + coinValueOf forged c == 1 && + coinValueOf forged liquidityCoin' == liquidity && + outA > 0 && + outB > 0 && + Constraints.checkOwnOutputConstraint ctx (OutputConstraint (Pool lp liquidity) $ + coin lpCoinA outA <> coin lpCoinB outB <> coin c 1) + where + poolOutput :: TxOut + poolOutput = case [o | o <- getContinuingOutputs ctx, coinValueOf (txOutValue o) c == 1] of + [o] -> o + _ -> traceError "expected exactly one pool output" + + outA, outB, liquidity :: Integer + outA = coinValueOf (txOutValue poolOutput) lpCoinA + outB = coinValueOf (txOutValue poolOutput) lpCoinB + liquidity = calculateInitialLiquidity outA outB + + forged :: Value + forged = txInfoForge $ scriptContextTxInfo ctx + + liquidityCoin' :: Coin + liquidityCoin' = let AssetClass (cs,_) = c in mkCoin cs $ lpTicker lp + +{-# INLINABLE validateCloseFactory #-} +validateCloseFactory :: Uniswap -> Coin -> [LiquidityPool] -> ScriptContext -> Bool +validateCloseFactory us c lps ctx = + traceIfFalse "Uniswap coin not present" (coinValueOf (valueWithin $ findOwnInput' ctx) usC == 1) && + traceIfFalse "wrong forge value" (txInfoForge info == negate (coin c 1 <> coin lC (snd lpLiquidity))) && + traceIfFalse "factory output wrong" + (Constraints.checkOwnOutputConstraint ctx $ OutputConstraint (Factory $ filter (/= fst lpLiquidity) lps) $ coin usC 1) + where + info :: TxInfo + info = scriptContextTxInfo ctx + + poolInput :: TxInInfo + poolInput = case [ i + | i <- txInfoInputs info + , coinValueOf (valueWithin i) c == 1 + ] of + [i] -> i + _ -> traceError "expected exactly one pool input" + + lpLiquidity :: (LiquidityPool, Integer) + lpLiquidity = case txOutDatumHash . txInInfoResolved $ poolInput of + Nothing -> traceError "pool input witness missing" + Just h -> findPoolDatum info h + + lC, usC :: Coin + lC = let AssetClass (cs, _) = c in mkCoin cs (lpTicker $ fst lpLiquidity) + usC = usCoin us + +{-# INLINABLE validateClosePool #-} +validateClosePool :: Uniswap -> ScriptContext -> Bool +validateClosePool us ctx = hasFactoryInput + where + info :: TxInfo + info = scriptContextTxInfo ctx + + hasFactoryInput :: Bool + hasFactoryInput = + traceIfFalse "Uniswap factory input expected" $ + coinValueOf (valueSpent info) (usCoin us) == 1 + +{-# INLINABLE validateRemove #-} +validateRemove :: Coin -> LiquidityPool -> Integer -> ScriptContext -> Bool +validateRemove c lp liquidity ctx = + traceIfFalse "zero removal" (diff > 0) && + traceIfFalse "removal of too much liquidity" (diff < liquidity) && + traceIfFalse "pool state coin missing" (coinValueOf inVal c == 1) && + traceIfFalse "wrong liquidity pool output" (fst lpLiquidity == lp) && + traceIfFalse "pool state coin missing from output" (coinValueOf outVal c == 1) && + traceIfFalse "liquidity tokens not burnt" (txInfoForge info == negate (coin lC diff)) && + traceIfFalse "non-positive liquidity" (outA > 0 && outB > 0) + where + info :: TxInfo + info = scriptContextTxInfo ctx + + ownInput :: TxInInfo + ownInput = findOwnInput' ctx + + output :: TxOut + output = case getContinuingOutputs ctx of + [o] -> o + _ -> traceError "expected exactly one Uniswap output" + + inVal, outVal :: Value + inVal = valueWithin ownInput + outVal = txOutValue output + + lpLiquidity :: (LiquidityPool, Integer) + lpLiquidity = case txOutDatumHash output of + Nothing -> traceError "pool output witness missing" + Just h -> findPoolDatum info h + + lC :: Coin + lC = let AssetClass (cs, _) = c in mkCoin cs (lpTicker lp) + + diff, inA, inB, outA, outB :: Integer + diff = liquidity - snd lpLiquidity + inA = coinValueOf inVal $ lpCoinA lp + inB = coinValueOf inVal $ lpCoinB lp + (outA, outB) = calculateRemoval inA inB liquidity diff + +{-# INLINABLE validateAdd #-} +validateAdd :: Coin -> LiquidityPool -> Integer -> ScriptContext -> Bool +validateAdd c lp liquidity ctx = + traceIfFalse "pool stake token missing from input" (coinValueOf inVal c == 1) && + traceIfFalse "output pool for same liquidity pair expected" (lp == fst outDatum) && + traceIfFalse "must not remove tokens" (delA >= 0 && delB >= 0) && + traceIfFalse "insufficient liquidity" (delL >= 0) && + traceIfFalse "wrong amount of liquidity tokens" (delL == calculateAdditionalLiquidity oldA oldB liquidity delA delB) && + traceIfFalse "wrong amount of liquidity tokens forged" (txInfoForge info == coin lC delL) + where + info :: TxInfo + info = scriptContextTxInfo ctx + + ownInput :: TxInInfo + ownInput = findOwnInput' ctx + + ownOutput :: TxOut + ownOutput = case [ o + | o <- getContinuingOutputs ctx + , coinValueOf (txOutValue o) c == 1 + ] of + [o] -> o + _ -> traceError "expected exactly on pool output" + + outDatum :: (LiquidityPool, Integer) + outDatum = case txOutDatum ownOutput of + Nothing -> traceError "pool output datum hash not found" + Just h -> findPoolDatum info h + + inVal, outVal :: Value + inVal = valueWithin ownInput + outVal = txOutValue ownOutput + + oldA, oldB, delA, delB, delL :: Integer + oldA = coinValueOf inVal aC + oldB = coinValueOf inVal bC + delA = coinValueOf outVal aC - oldA + delB = coinValueOf outVal bC - oldB + delL = snd outDatum - liquidity + + aC, bC, lC :: Coin + aC = lpCoinA lp + bC = lpCoinB lp + lC = let AssetClass (cs, _) = c in mkCoin cs $ lpTicker lp + + +{-# INLINABLE findPoolDatum #-} +findPoolDatum :: TxInfo -> DatumHash -> (LiquidityPool, Integer) +findPoolDatum info h = case findDatum h info of + Just (Datum d) -> case PlutusTx.fromData d of + Just (Pool lp a) -> (lp, a) + _ -> traceError "error decoding data" + _ -> traceError "pool input datum not found" + +{-# INLINABLE lpTicker #-} +lpTicker :: LiquidityPool -> TokenName +lpTicker LiquidityPool{..} = TokenName $ + unCurrencySymbol c_cs `concatenate` + unCurrencySymbol d_cs `concatenate` + unTokenName c_tok `concatenate` + unTokenName d_tok + where + (AssetClass (c_cs, c_tok), AssetClass (d_cs, d_tok)) + | lpCoinA < lpCoinB = (lpCoinA, lpCoinB) + + | otherwise = (lpCoinB, lpCoinA) + +-- | Gets the 'Coin' used to identity liquidity pools. +poolStateCoinFromUniswapCurrency :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. + -> Coin +poolStateCoinFromUniswapCurrency = poolStateCoin . uniswap + + +-- the actual Validator +-- basically a sub-function switch +mkUniswapValidator :: Uniswap + -> Coin + -> UniswapDatum + -> UniswapAction + -> ScriptContext + -> Bool +mkUniswapValidator us c (Factory lps) (Create lp) ctx = validateCreate us c lps lp ctx +mkUniswapValidator _ c (Pool lp _) Swap ctx = validateSwap lp c ctx +mkUniswapValidator us c (Factory lps) Close ctx = validateCloseFactory us c lps ctx +mkUniswapValidator us _ (Pool _ _) Close ctx = validateClosePool us ctx +mkUniswapValidator _ c (Pool lp a) Remove ctx = validateRemove c lp a ctx +mkUniswapValidator _ c (Pool lp a) Add ctx = validateAdd c lp a ctx +mkUniswapValidator _ _ _ _ _ = False + + +uniswapInstance :: Uniswap -> Scripts.ScriptInstance Uniswapping +uniswapInstance us = Scripts.validator @Uniswapping + ($$(PlutusTx.compile [|| mkUniswapValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode us + `PlutusTx.applyCode` PlutusTx.liftCode c) + $$(PlutusTx.compile [|| wrap ||]) + where + c :: Coin + c = poolStateCoin us + + wrap = Scripts.wrapValidator @UniswapDatum @UniswapAction + +uniswapScript :: Uniswap -> Validator +uniswapScript = Scripts.validatorScript . uniswapInstance + +uniswapAddress :: Uniswap -> Ledger.Address +uniswapAddress = Ledger.scriptAddress . uniswapScript + +uniswap :: CurrencySymbol -> Uniswap +uniswap cs = Uniswap $ mkCoin cs uniswapTokenName + +getUniswapDatum :: TxOutTx -> Contract w s Text UniswapDatum +getUniswapDatum o = case txOutDatumHash $ txOutTxOut o of + Nothing -> throwError "datumHash not found" + Just h -> case Map.lookup h $ txData $ txOutTxTx o of + Nothing -> throwError "datum not found" + Just (Datum e) -> case PlutusTx.fromData e of + Nothing -> throwError "datum has wrong type" + Just d -> return d + +findUniswapInstance :: HasBlockchainActions s => Uniswap -> Coin -> (UniswapDatum -> Maybe a) -> Contract w s Text (TxOutRef, TxOutTx, a) +findUniswapInstance us c f = do + let addr = uniswapAddress us + logInfo @String $ printf "looking for Uniswap instance at address %s containing coin %s " (show addr) (show c) + utxos <- utxoAt addr + go [x | x@(_, o) <- Map.toList utxos, coinValueOf (txOutValue $ txOutTxOut o) c == 1] + where + go [] = throwError "Uniswap instance not found" + go ((oref, o) : xs) = do + d <- getUniswapDatum o + case f d of + Nothing -> go xs + Just a -> do + logInfo @String $ printf "found Uniswap instance with datum: %s" (show d) + return (oref, o, a) + +findUniswapFactory :: HasBlockchainActions s => Uniswap -> Contract w s Text (TxOutRef, TxOutTx, [LiquidityPool]) +findUniswapFactory us@Uniswap{..} = findUniswapInstance us usCoin $ \case + Factory lps -> Just lps + Pool _ _ -> Nothing + +findUniswapPool :: HasBlockchainActions s => Uniswap -> LiquidityPool -> Contract w s Text (TxOutRef, TxOutTx, Integer) +findUniswapPool us lp = findUniswapInstance us (poolStateCoin us) $ \case + Pool lp' l + | lp == lp' -> Just l + _ -> Nothing + +findUniswapFactoryAndPool :: HasBlockchainActions s + => Uniswap + -> Coin + -> Coin + -> Contract w s Text ( (TxOutRef, TxOutTx, [LiquidityPool]) + , (TxOutRef, TxOutTx, LiquidityPool, Integer) + ) +findUniswapFactoryAndPool us coinA coinB = do + (oref1, o1, lps) <- findUniswapFactory us + case [ lp' + | lp' <- lps + , lp' == LiquidityPool coinA coinB + ] of + [lp] -> do + (oref2, o2, a) <- findUniswapPool us lp + return ( (oref1, o1, lps) + , (oref2, o2, lp, a) + ) + _ -> throwError "liquidity pool not found" + +-- | Gets the liquidity token for a given liquidity pool. +liquidityCoin :: CurrencySymbol -- ^ The currency identifying the Uniswap instance. + -> Coin -- ^ One coin in the liquidity pair. + -> Coin -- ^ The other coin in the liquidity pair. + -> Coin +liquidityCoin cs coinA coinB = mkCoin (liquidityCurrency $ uniswap cs) $ lpTicker $ LiquidityPool coinA coinB \ No newline at end of file