Skip to content

Commit

Permalink
remove resourceT
Browse files Browse the repository at this point in the history
  • Loading branch information
@Bromel777
Bromel777 committed Jul 19, 2023
1 parent 4d895f2 commit 9d750e9
Show file tree
Hide file tree
Showing 14 changed files with 228 additions and 177 deletions.
2 changes: 1 addition & 1 deletion cabal.project
View file
Original file line number Diff line number Diff line change
Expand Up @@ -313,7 +313,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/ergolabs/cardano-dex-contracts
tag: 2fb44f444897d84e313ceb4d3d467441385802dd
tag: 7850574a9b7f3e33cd7fc16f5fcdbbf0c8de68df
subdir:
cardano-dex-contracts-offchain

Expand Down
95 changes: 56 additions & 39 deletions dex-core/src/ErgoDex/Amm/Pool.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ import Ledger
import Ledger.Value (assetClassValue, assetClassValueOf)
import PlutusTx.IsData.Class
import PlutusTx.Sqrt
import Plutus.V1.Ledger.Api (StakingCredential(..))
import PlutusTx.Numeric (AdditiveMonoid(zero))
import Ledger.Ada (lovelaceValueOf)
import Plutus.Script.Utils.V2.Address (mkValidatorAddress)
Expand Down Expand Up @@ -42,55 +43,65 @@ data PoolFee = PoolFee
} deriving (Show, Eq, Generic, FromJSON, ToJSON)

data Pool = Pool
{ poolId :: PoolId
, poolReservesX :: Amount X
, poolReservesY :: Amount Y
, poolLiquidity :: Amount Liquidity
, poolCoinX :: Coin X
, poolCoinY :: Coin Y
, poolCoinLq :: Coin Liquidity
, poolFee :: PoolFee
, outCollateral :: Amount Lovelace
{ poolId :: PoolId
, poolReservesX :: Amount X
, poolReservesY :: Amount Y
, poolLiquidity :: Amount Liquidity
, poolCoinX :: Coin X
, poolCoinY :: Coin Y
, poolCoinLq :: Coin Liquidity
, poolFee :: PoolFee
, outCollateral :: Amount Lovelace
, stakeAdminPolicy :: [CurrencySymbol]
, lqBound :: Amount X
, stakeCred :: Maybe StakingCredential
} deriving (Show, Eq, Generic, FromJSON, ToJSON)

feeDen :: Integer
feeDen = 1000

instance FromLedger Pool where
parseFromLedger fout@FullTxOut{fullTxOutDatum=(KnownDatum (Datum d)), ..} = --todo add also check for address
parseFromLedger fout@FullTxOut{fullTxOutDatum=(KnownDatum (Datum d)), fullTxOutAddress=Address{..}, ..} = --todo add also check for address
case fromBuiltinData d of
(Just PoolConfig{..}) -> do
let
rx = Amount $ assetClassValueOf fullTxOutValue poolX
ry = Amount $ assetClassValueOf fullTxOutValue poolY
rlq = Amount $ assetClassValueOf fullTxOutValue poolLq
nft = Amount $ assetClassValueOf fullTxOutValue poolNft
lq = maxLqCapAmount - rlq -- actual LQ emission
rx = Amount $ assetClassValueOf fullTxOutValue poolX
ry = Amount $ assetClassValueOf fullTxOutValue poolY
rlq = Amount $ assetClassValueOf fullTxOutValue poolLq
nft = Amount $ assetClassValueOf fullTxOutValue poolNft
lqBoundAmount = Amount lqBound
lq = maxLqCapAmount - rlq -- actual LQ emission
collateral = if W.isAda poolX || W.isAda poolY then zero else minSafeOutputAmount
when (rx == 0 || ry == 0 || rlq == 0 || nft /= 1) Nothing
Just $ OnChain fout Pool
{ poolId = PoolId $ Coin poolNft
, poolReservesX = rx
, poolReservesY = ry
, poolLiquidity = lq
, poolCoinX = Coin poolX
, poolCoinY = Coin poolY
, poolCoinLq = Coin poolLq
, poolFee = PoolFee poolFeeNum feeDen
, outCollateral = collateral
{ poolId = PoolId $ Coin poolNft
, poolReservesX = rx
, poolReservesY = ry
, poolLiquidity = lq
, poolCoinX = Coin poolX
, poolCoinY = Coin poolY
, poolCoinLq = Coin poolLq
, poolFee = PoolFee poolFeeNum feeDen
, outCollateral = collateral
, stakeAdminPolicy = stakeAdminPolicy
, lqBound = lqBoundAmount
, stakeCred = addressStakingCredential
}
_ -> Nothing
parseFromLedger _ = Nothing

instance ToLedger PoolValidatorV1 Pool where
toLedger (PoolValidator poolValidator) Pool{..} =
TxOutCandidate
{ txOutCandidateAddress = mkValidatorAddress poolValidator
{ txOutCandidateAddress = poolAddress
, txOutCandidateValue = poolValue
, txOutCandidateDatum = KnownDatum $ Datum $ toBuiltinData poolConf
, txOutCandidateRefScript = Nothing
}
where
poolAddress = (mkValidatorAddress poolValidator) {
addressStakingCredential = stakeCred
}
nft = unPoolId poolId
poolLqReserves = maxLqCapAmount - poolLiquidity
poolValue = assetClassValue (unCoin nft) 1 <>
Expand All @@ -100,18 +111,21 @@ instance ToLedger PoolValidatorV1 Pool where
lovelaceValueOf (unAmount outCollateral)

poolConf = PoolConfig
{ poolNft = unCoin nft
, poolX = unCoin poolCoinX
, poolY = unCoin poolCoinY
, poolLq = unCoin poolCoinLq
, poolFeeNum = poolFeeNum' poolFee
{ poolNft = unCoin nft
, poolX = unCoin poolCoinX
, poolY = unCoin poolCoinY
, poolLq = unCoin poolCoinLq
, poolFeeNum = poolFeeNum' poolFee
, stakeAdminPolicy = stakeAdminPolicy
, lqBound = unAmount lqBound
}

data PoolInitError
= InvalidLiquidity Integer
| InsufficientInitialLiqudity (Amount Liquidity)
deriving (Show, Eq)

-- todo: remove me
initPool
:: PoolValidator V1
-> S.PoolConfig
Expand All @@ -128,15 +142,18 @@ initPool poolValidator S.PoolConfig{..} burnLq (inX, inY) = do
then zero
else minSafeOutputAmount
pool = Pool
{ poolId = PoolId poolNft
, poolReservesX = inX
, poolReservesY = inY
, poolLiquidity = releasedLq
, poolCoinX = poolX
, poolCoinY = poolY
, poolCoinLq = poolLq
, poolFee = PoolFee poolFeeNum feeDen
, outCollateral = outCollateral
{ poolId = PoolId poolNft
, poolReservesX = inX
, poolReservesY = inY
, poolLiquidity = releasedLq
, poolCoinX = poolX
, poolCoinY = poolY
, poolCoinLq = poolLq
, poolFee = PoolFee poolFeeNum feeDen
, stakeAdminPolicy = []
, lqBound = 10000
, outCollateral = outCollateral
, stakeCred = Nothing
}
poolOut = toLedger poolValidator pool
pure (Predicted poolOut pool, releasedLq)
Expand Down
80 changes: 23 additions & 57 deletions dex-core/src/ErgoDex/Amm/PoolActions.hs
View file
Original file line number Diff line number Diff line change
@@ -1,15 +1,13 @@
module ErgoDex.Amm.PoolActions
( PoolActions(..)
, OrderExecErr(..)
, PoolActionsConfig(..)
, mkPoolActions
, AmmValidators(..)
, fetchValidatorsV1
) where

import Control.Exception.Base
import qualified Data.Set as Set
import Dhall (FromDhall)
import Data.Bifunctor
import Data.Tuple
import RIO
Expand All @@ -31,15 +29,12 @@ import qualified ErgoDex.Contracts.Proxy.Order as O
import ErgoDex.Contracts.Types
import CardanoTx.Models

data PoolActionsConfig = PoolActionsConfig
{ safeTxFeeLovalace :: Integer
} deriving (Generic, FromDhall)

data OrderExecErr
= PriceTooHigh
| PoolMismatch PoolId PoolId
| EmptyPool PoolId
| PoolNotFoundInFinalTx PoolId
| InsufficientPoolLqForSwap PoolId
deriving (Show)

instance Exception OrderExecErr
Expand All @@ -65,11 +60,11 @@ data PoolActions = PoolActions
, runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool)
}

mkPoolActions :: PoolActionsConfig -> PaymentPubKeyHash -> AmmValidators V1 -> PoolActions
mkPoolActions cfg executorPkh AmmValidators{..} = PoolActions
{ runSwap = runSwap' cfg executorPkh poolV swapV
, runDeposit = runDeposit' cfg executorPkh poolV depositV
, runRedeem = runRedeem' cfg executorPkh poolV redeemV
mkPoolActions :: PaymentPubKeyHash -> AmmValidators V1 -> PoolActions
mkPoolActions executorPkh AmmValidators{..} = PoolActions
{ runSwap = runSwap' executorPkh poolV swapV
, runDeposit = runDeposit' executorPkh poolV depositV
, runRedeem = runRedeem' executorPkh poolV redeemV
}

newtype PoolIn = PoolIn FullTxOut
Expand All @@ -93,22 +88,22 @@ mkOrderInputs action (PoolValidator pv) ov' (PoolIn poolOut) (OrderIn orderOut)
in Set.fromList [poolIn, orderIn]

runSwap'
:: PoolActionsConfig
-> PaymentPubKeyHash
:: PaymentPubKeyHash
-> PoolValidator V1
-> SwapValidator V1
-> [FullTxOut]
-> OnChain Swap
-> (FullTxOut, Pool)
-> Either OrderExecErr (TxCandidate, Predicted Pool)
runSwap' PoolActionsConfig{..} executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerToken{..}, ..}) (poolOut, pool) = do
runSwap' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerToken{..}, ..}) (poolOut, pool) = do
let
inputs = mkOrderInputs P.Swap pv sv (PoolIn poolOut) (OrderIn swapOut)
pp@(Predicted nextPoolOut _) = applySwap pv pool (AssetAmount swapBase swapBaseIn)
quoteOutput = outputAmount pool (AssetAmount swapBase swapBaseIn)

when (swapPoolId /= poolId pool) (Left $ PoolMismatch swapPoolId (poolId pool))
when (getAmount quoteOutput < swapMinQuoteOut) (Left PriceTooHigh)
when (lqBound pool <= poolReservesX pool * 2) (Left $ InsufficientPoolLqForSwap (poolId pool))

let
exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen
Expand All @@ -128,39 +123,29 @@ runSwap' PoolActionsConfig{..} executorPkh pv sv refInputs (OnChain swapOut Swap
<> Ada.lovelaceValueOf (negate exFee) -- Remove Batcher Fee

rewardValue = assetAmountValue quoteOutput <> residualValue

executorRewardPkh = pubKeyHashAddress executorPkh Nothing
exexutorRewardOut =
TxOutCandidate
{ txOutCandidateAddress = executorRewardPkh
, txOutCandidateValue = Ada.lovelaceValueOf (exFee - safeTxFeeLovalace)
, txOutCandidateDatum = EmptyDatum
, txOutCandidateRefScript = Nothing
}

txCandidate = TxCandidate
{ txCandidateInputs = inputs
, txCandidateRefIns = refInputs
, txCandidateOutputs = [nextPoolOut, rewardOut, exexutorRewardOut]
, txCandidateOutputs = [nextPoolOut, rewardOut]
, txCandidateValueMint = mempty
, txCandidateMintInputs = mempty
, txCandidateChangePolicy = Just . ReturnTo $ rewardAddr
, txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing
, txCandidateValidRange = Interval.always
, txCandidateSigners = mempty
}

Right (txCandidate, pp)

runDeposit'
:: PoolActionsConfig
-> PaymentPubKeyHash
:: PaymentPubKeyHash
-> PoolValidator V1
-> DepositValidator V1
-> [FullTxOut]
-> OnChain Deposit
-> (FullTxOut, Pool)
-> Either OrderExecErr (TxCandidate, Predicted Pool)
runDeposit' PoolActionsConfig{..} executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do
runDeposit' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do
when (depositPoolId /= poolId) (Left $ PoolMismatch depositPoolId poolId)
let
inputs = mkOrderInputs P.Deposit pv dv (PoolIn poolOut) (OrderIn depositOut)
Expand Down Expand Up @@ -206,46 +191,36 @@ runDeposit' PoolActionsConfig{..} executorPkh pv dv refInputs (OnChain depositOu
<> Ada.lovelaceValueOf (negate $ unAmount exFee) -- Remove Fee
rewardValue = residualValue <> mintLqValue <> alignmentValue

executorRewardPkh = pubKeyHashAddress executorPkh Nothing
exexutorRewardOut =
TxOutCandidate
{ txOutCandidateAddress = executorRewardPkh
, txOutCandidateValue = Ada.lovelaceValueOf $ (unAmount exFee - safeTxFeeLovalace)
, txOutCandidateDatum = EmptyDatum
, txOutCandidateRefScript = Nothing
}

txCandidate = TxCandidate
{ txCandidateInputs = inputs
, txCandidateRefIns = refInputs
, txCandidateOutputs = [nextPoolOut, rewardOut, exexutorRewardOut]
, txCandidateOutputs = [nextPoolOut, rewardOut]
, txCandidateValueMint = mempty
, txCandidateMintInputs = mempty
, txCandidateChangePolicy = Just . ReturnTo $ rewardAddr
, txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing
, txCandidateValidRange = Interval.always
, txCandidateSigners = mempty
}

Right (txCandidate, pp)

runRedeem'
:: PoolActionsConfig
-> PaymentPubKeyHash
:: PaymentPubKeyHash
-> PoolValidator V1
-> RedeemValidator V1
-> [FullTxOut]
-> OnChain Redeem
-> (FullTxOut, Pool)
-> Either OrderExecErr (TxCandidate, Predicted Pool)
runRedeem' PoolActionsConfig{..} executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do
runRedeem' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do
when (redeemPoolId /= poolId) (Left $ PoolMismatch redeemPoolId poolId)
let
inputs = mkOrderInputs P.Redeem pv rv (PoolIn poolOut) (OrderIn redeemOut)

pp@(Predicted nextPoolOut _) = applyRedeem pv pool redeemLqIn

burnLqValue = assetClassValue (unCoin redeemLq) (negate $ unAmount redeemLqIn)

exFee = unAmount $ unExFee redeemExFee

rewardAddr = pubKeyHashAddress (PaymentPubKeyHash redeemRewardPkh) redeemRewardSPkh
Expand All @@ -260,29 +235,20 @@ runRedeem' PoolActionsConfig{..} executorPkh pv rv refInputs (OnChain redeemOut
(outX, outY) = sharesAmount pool redeemLqIn
initValue = fullTxOutValue redeemOut
negatedExFe = Ada.lovelaceValueOf . negate $ exFee
residualValue =
initValue
<> burnLqValue
residualValue =
initValue
<> burnLqValue
<> negatedExFe -- Remove LQ input and ExFee

rewardValue = assetAmountValue outX <> assetAmountValue outY <> residualValue

executorRewardPkh = pubKeyHashAddress executorPkh Nothing
exexutorRewardOut =
TxOutCandidate
{ txOutCandidateAddress = executorRewardPkh
, txOutCandidateValue = Ada.lovelaceValueOf (exFee - safeTxFeeLovalace)
, txOutCandidateDatum = EmptyDatum
, txOutCandidateRefScript = Nothing
}

txCandidate = TxCandidate
{ txCandidateInputs = inputs
, txCandidateRefIns = refInputs
, txCandidateOutputs = [nextPoolOut, rewardOut, exexutorRewardOut]
, txCandidateOutputs = [nextPoolOut, rewardOut]
, txCandidateValueMint = mempty
, txCandidateMintInputs = mempty
, txCandidateChangePolicy = Just . ReturnTo $ rewardAddr
, txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing
, txCandidateValidRange = Interval.always
, txCandidateSigners = mempty
}
Expand Down
1 change: 1 addition & 0 deletions dex-core/src/ErgoDex/Amm/PoolSetup.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -44,6 +44,7 @@ mkPoolSetup pv changeAddr = PoolSetup
{ poolDeploy = poolDeploy' pv burnLqInitial changeAddr
}

-- todo: remove me
poolDeploy'
:: PoolValidatorV1
-> Amount Liquidity
Expand Down
Loading

0 comments on commit 9d750e9

Please sign in to comment.