From fcac32d65975b53b2421f67254355765860a4e4b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 5 Jun 2023 11:42:06 +0200 Subject: [PATCH 01/50] Add path delimiter --- ergo-hs-common/ergo-hs-common.cabal | 1 + .../src/Common/String/Formatting.hs | 6 ++++++ quickblue/src/Explorer/Config.hs | 4 ++++ quickblue/src/Explorer/Service.hs | 19 ++++++++++--------- 4 files changed, 21 insertions(+), 9 deletions(-) create mode 100644 ergo-hs-common/src/Common/String/Formatting.hs diff --git a/ergo-hs-common/ergo-hs-common.cabal b/ergo-hs-common/ergo-hs-common.cabal index 61681463..158d0eef 100644 --- a/ergo-hs-common/ergo-hs-common.cabal +++ b/ergo-hs-common/ergo-hs-common.cabal @@ -74,5 +74,6 @@ library exposed-modules: Common.Throw.Combinators Common.Data.List.Combinators + Common.String.Formatting build-depends: rio, plutus-ledger-api, plutus-tx, containers \ No newline at end of file diff --git a/ergo-hs-common/src/Common/String/Formatting.hs b/ergo-hs-common/src/Common/String/Formatting.hs new file mode 100644 index 00000000..04253a68 --- /dev/null +++ b/ergo-hs-common/src/Common/String/Formatting.hs @@ -0,0 +1,6 @@ +module Common.String.Formatting where + +import qualified Data.Char as DC + +toLower :: String -> String +toLower = map DC.toLower \ No newline at end of file diff --git a/quickblue/src/Explorer/Config.hs b/quickblue/src/Explorer/Config.hs index 228c291d..8eb81a46 100644 --- a/quickblue/src/Explorer/Config.hs +++ b/quickblue/src/Explorer/Config.hs @@ -7,8 +7,12 @@ newtype Uri = Uri { unUri :: String } deriving Generic deriving newtype (Show, FromDhall) +data Network = Mainnet | Preview + deriving (Generic, Show, FromDhall) + data ExplorerConfig = ExplorerConfig { explorerUri :: Uri + , network :: Network } deriving (Generic, Show) instance FromDhall ExplorerConfig \ No newline at end of file diff --git a/quickblue/src/Explorer/Service.hs b/quickblue/src/Explorer/Service.hs index a2dfd388..72710465 100644 --- a/quickblue/src/Explorer/Service.hs +++ b/quickblue/src/Explorer/Service.hs @@ -14,6 +14,7 @@ import Explorer.Config import Ledger ( TxOutRef, txOutRefId, txOutRefIdx ) import Prelude hiding (Ordering) import System.Logging.Hlog (Logging (Logging, debugM), MakeLogging (MakeLogging, forComponent)) +import Common.String.Formatting (toLower) data Explorer f = Explorer { getOutput :: TxOutRef -> f (Maybe FullTxOut) @@ -35,23 +36,23 @@ mkExplorer MakeLogging{..} conf = do } getOutput' :: MonadIO f => Logging f -> ExplorerConfig -> TxOutRef -> f (Maybe FullTxOut) -getOutput' logging conf ref = - mkGetRequest logging conf $ "/cardano/v1/outputs/" ++ renderTxOutRef ref +getOutput' logging conf@ExplorerConfig{..} ref = + mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/" ++ renderTxOutRef ref getUnspentOutputs' :: MonadIO f => Logging f -> ExplorerConfig -> Gix -> Limit -> Ordering -> f (Items FullTxOut) -getUnspentOutputs' logging conf minIndex limit ordering = - mkGetRequest logging conf $ "/cardano/v1/outputs/unspent/indexed?minIndex=" ++ show minIndex ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering +getUnspentOutputs' logging conf@ExplorerConfig{..} minIndex limit ordering = + mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/unspent/indexed?minIndex=" ++ show minIndex ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering getUnspentOutputsByPCred' :: MonadIO f => Logging f -> ExplorerConfig -> PaymentCred -> Paging -> f (Items FullTxOut) -getUnspentOutputsByPCred' logging conf pcred Paging{..} = - mkGetRequest logging conf $ "/cardano/v1/outputs/unspent/byPaymentCred/" ++ T.unpack (unPaymentCred pcred) ++ "/?offset=" ++ show offset ++ "&limit=" ++ show limit +getUnspentOutputsByPCred' logging conf@ExplorerConfig{..} pcred Paging{..} = + mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/unspent/byPaymentCred/" ++ T.unpack (unPaymentCred pcred) ++ "/?offset=" ++ show offset ++ "&limit=" ++ show limit getSystemEnv' :: MonadIO f => Logging f -> ExplorerConfig -> f SystemEnv -getSystemEnv' logging conf = mkGetRequest logging conf "/cardano/v1/networkParams" +getSystemEnv' logging conf@ExplorerConfig{..} = mkGetRequest logging conf ("/cardano/v1/" ++ toLower (show network) ++ "/networkParams") getTxs' :: MonadIO f => Logging f -> ExplorerConfig -> Paging -> Ordering -> f (Items FullTx) -getTxs' logging conf Paging{..} ordering = - mkGetRequest logging conf $ "/cardano/v1/transactions/?offset=" ++ show offset ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering +getTxs' logging conf@ExplorerConfig{..} Paging{..} ordering = + mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/transactions/?offset=" ++ show offset ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering mkGetRequest :: (MonadIO f, FromJSON a, Show a) => Logging f -> ExplorerConfig -> String -> f a mkGetRequest Logging{..} ExplorerConfig{..} path = do From 4d895f281c9859b971b08db9722d2ec80718cc17 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 12 Jun 2023 22:04:33 +0200 Subject: [PATCH 02/50] Fix incorrect balancing check --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index c294b8ee..4cc0696a 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -270,10 +270,11 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams :: TxOut CtxTx era -> ProtocolParameters -> Either TxBodyErrorAutoBalance () - checkMinUTxOValue txout@(TxOut _ v _ _) pparams' = do + checkMinUTxOValue txout@(TxOut addr v _ _) pparams' = do minUTxO <- first TxBodyErrorMinUTxOMissingPParams $ calculateMinimumUTxO era txout pparams' - if txOutValueToLovelace v >= selectLovelace minUTxO + let chargeBoxWillBeMerged = addr == changeaddr + if txOutValueToLovelace v >= selectLovelace minUTxO || chargeBoxWillBeMerged then Right () else Left TxBodyErrorMissingParamMinUTxO --todo fix: TxOutInAnyEra. Current err is incorrect From 9d750e9a5f511f644b8ad2cdbf2b261425a5c939 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 19 Jun 2023 10:12:34 +0200 Subject: [PATCH 03/50] remove resourceT --- cabal.project | 2 +- dex-core/src/ErgoDex/Amm/Pool.hs | 95 +++++++++++-------- dex-core/src/ErgoDex/Amm/PoolActions.hs | 80 +++++----------- dex-core/src/ErgoDex/Amm/PoolSetup.hs | 1 + dex-core/test/Spec/Pool.hs | 29 +++--- ledger-sync/ledger-sync.cabal | 1 + .../EventSource/Persistence/LedgerHistory.hs | 92 ++++++++++++++---- .../src/Spectrum/EventSource/Stream.hs | 72 ++++++++------ ledger-sync/src/Spectrum/LedgerSync.hs | 21 ++-- .../Spectrum/LedgerSync/Data/LedgerUpdate.hs | 6 +- nix/pkgs/haskell/haskell.nix | 2 +- submit-api/src/SubmitAPI/Service.hs | 1 + submit-api/submit-api.cabal | 1 + wallet-api/src/WalletAPI/Utxos.hs | 2 +- 14 files changed, 228 insertions(+), 177 deletions(-) diff --git a/cabal.project b/cabal.project index a49ebb14..ef1d1ff6 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/dex-core/src/ErgoDex/Amm/Pool.hs b/dex-core/src/ErgoDex/Amm/Pool.hs index 0d4d2746..c7bce0d0 100644 --- a/dex-core/src/ErgoDex/Amm/Pool.hs +++ b/dex-core/src/ErgoDex/Amm/Pool.hs @@ -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) @@ -42,42 +43,49 @@ 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 @@ -85,12 +93,15 @@ instance FromLedger Pool where 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 <> @@ -100,11 +111,13 @@ 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 @@ -112,6 +125,7 @@ data PoolInitError | InsufficientInitialLiqudity (Amount Liquidity) deriving (Show, Eq) +-- todo: remove me initPool :: PoolValidator V1 -> S.PoolConfig @@ -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) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 3dd77d42..8e336b73 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -1,7 +1,6 @@ module ErgoDex.Amm.PoolActions ( PoolActions(..) , OrderExecErr(..) - , PoolActionsConfig(..) , mkPoolActions , AmmValidators(..) , fetchValidatorsV1 @@ -9,7 +8,6 @@ module ErgoDex.Amm.PoolActions import Control.Exception.Base import qualified Data.Set as Set -import Dhall (FromDhall) import Data.Bifunctor import Data.Tuple import RIO @@ -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 @@ -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 @@ -93,15 +88,14 @@ 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) @@ -109,6 +103,7 @@ runSwap' PoolActionsConfig{..} executorPkh pv sv refInputs (OnChain swapOut Swap 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 @@ -128,23 +123,14 @@ 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 } @@ -152,15 +138,14 @@ runSwap' PoolActionsConfig{..} executorPkh pv sv refInputs (OnChain swapOut Swap 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) @@ -206,22 +191,13 @@ 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 } @@ -229,15 +205,14 @@ runDeposit' PoolActionsConfig{..} executorPkh pv dv refInputs (OnChain depositOu 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) @@ -245,7 +220,7 @@ runRedeem' PoolActionsConfig{..} executorPkh pv rv refInputs (OnChain redeemOut pp@(Predicted nextPoolOut _) = applyRedeem pv pool redeemLqIn burnLqValue = assetClassValue (unCoin redeemLq) (negate $ unAmount redeemLqIn) - + exFee = unAmount $ unExFee redeemExFee rewardAddr = pubKeyHashAddress (PaymentPubKeyHash redeemRewardPkh) redeemRewardSPkh @@ -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 } diff --git a/dex-core/src/ErgoDex/Amm/PoolSetup.hs b/dex-core/src/ErgoDex/Amm/PoolSetup.hs index ea0d8f43..8d7ca8ca 100644 --- a/dex-core/src/ErgoDex/Amm/PoolSetup.hs +++ b/dex-core/src/ErgoDex/Amm/PoolSetup.hs @@ -44,6 +44,7 @@ mkPoolSetup pv changeAddr = PoolSetup { poolDeploy = poolDeploy' pv burnLqInitial changeAddr } +-- todo: remove me poolDeploy' :: PoolValidatorV1 -> Amount Liquidity diff --git a/dex-core/test/Spec/Pool.hs b/dex-core/test/Spec/Pool.hs index a85002c8..be4592f5 100644 --- a/dex-core/test/Spec/Pool.hs +++ b/dex-core/test/Spec/Pool.hs @@ -80,7 +80,7 @@ initialLiquidityTests = testGroup "InitialLiquidity" initialLiquidityAmount poolLq (Amount 10, Amount 11) @?= Right (AssetAmount poolLq 11) ] -poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum +poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum [] 0 sufficientInitDepositX = Amount 800 @@ -91,20 +91,25 @@ initDepositY = Amount 2000 releasedLq = Amount 265 nativePool = Pool - { poolId = PoolId poolNft - , poolReservesX = sufficientInitDepositX - , poolReservesY = initDepositY - , poolLiquidity = releasedLq - , poolCoinX = poolX - , poolCoinY = poolY - , poolCoinLq = poolLq - , poolFee = PoolFee poolFeeNum feeDen - , outCollateral = minSafeOutputAmount + { poolId = PoolId poolNft + , poolReservesX = sufficientInitDepositX + , poolReservesY = initDepositY + , poolLiquidity = releasedLq + , poolCoinX = poolX + , poolCoinY = poolY + , poolCoinLq = poolLq + , poolFee = PoolFee poolFeeNum feeDen + , outCollateral = minSafeOutputAmount + , stakeAdminPolicy = [] + , lqBound = Amount 0 + , stakeCred = Nothing } +-- todo: remove me initPoolTests = testGroup "NonNativePoolInit" - [ HH.testProperty "init_non_native_pool_sufficient_liquidity" initNonNativePoolSufficientLiquidity - , HH.testProperty "init_non_native_pool_insufficient_liquidity" initNonNativePoolInsufficientLiquidity + [ + -- HH.testProperty "init_non_native_pool_sufficient_liquidity" initNonNativePoolSufficientLiquidity + -- , HH.testProperty "init_non_native_pool_insufficient_liquidity" initNonNativePoolInsufficientLiquidity ] initNonNativePoolInsufficientLiquidity :: Property diff --git a/ledger-sync/ledger-sync.cabal b/ledger-sync/ledger-sync.cabal index 7ffa302b..b053219a 100755 --- a/ledger-sync/ledger-sync.cabal +++ b/ledger-sync/ledger-sync.cabal @@ -164,3 +164,4 @@ library , dependent-sum-template >= 0.1 && < 0.2 , dependent-map >= 0.3 && < 0.5 , aeson-gadt-th + , strict-containers diff --git a/ledger-sync/src/Spectrum/EventSource/Persistence/LedgerHistory.hs b/ledger-sync/src/Spectrum/EventSource/Persistence/LedgerHistory.hs index d14ef9ec..9e3b996b 100755 --- a/ledger-sync/src/Spectrum/EventSource/Persistence/LedgerHistory.hs +++ b/ledger-sync/src/Spectrum/EventSource/Persistence/LedgerHistory.hs @@ -2,6 +2,7 @@ module Spectrum.EventSource.Persistence.LedgerHistory ( LedgerHistory(..) , mkLedgerHistory , mkRuntimeLedgerHistory + , TestStack(..) ) where import RIO @@ -10,6 +11,7 @@ import RIO , newIORef , readIORef , writeIORef + , atomicModifyIORef' , (<&>) , isJust ) @@ -34,6 +36,42 @@ import Spectrum.EventSource.Persistence.Config ( LedgerStoreConfig (..) ) import Spectrum.Common.Persistence.Serialization (serialize, deserializeM) import Control.Monad.Catch (MonadThrow) +import Data.List (uncons) +import GHC.IORef (IORef(IORef)) +import Data.Foldable (find) + +data TestStack m k = TestStack + { push :: k -> m () + , pop :: m (Maybe k) + , readFirst :: m (Maybe k) + , exists :: k -> m Bool + } + +mkTestStack :: (MonadIO f, MonadIO m, Eq k) => f (TestStack m k) +mkTestStack = do + listRef <- newIORef [] + let size = 100 + return TestStack + { push = \elem -> do + atomicModifyIORef' listRef (\listStack -> + if length listStack > size + then + let + (newStack, _) = splitAt (size `div` 2) listStack + in (elem : newStack, ()) + else (elem : listStack, ()) + ) + , pop = + atomicModifyIORef' listRef (\listStack -> + case uncons listStack of + Nothing -> ([], Nothing) + Just (element, newStack) -> (newStack, Just element) + ) + , readFirst = readIORef listRef <&> (\list -> uncons list <&> fst) + , exists = \key -> do + list <- readIORef listRef + pure $ elem key list + } data LedgerHistory m = LedgerHistory { setTip :: ConcretePoint -> m () @@ -73,34 +111,50 @@ mkLedgerHistory MakeLogging{..} LedgerStoreConfig{..} = do } -- | Runtime-only storage primarily for tests. -mkRuntimeLedgerHistory :: (MonadIO m, MonadThrow m) => MakeLogging m m -> m (LedgerHistory m) -mkRuntimeLedgerHistory MakeLogging{..} = do +mkRuntimeLedgerHistory :: (MonadIO m, MonadThrow m) => m (LedgerHistory m) +mkRuntimeLedgerHistory = do + tipsStack <- mkTestStack + blockStorage <- newIORef [] store <- newIORef mempty - logging <- forComponent "LedgerHistory" - pure $ attachLogging logging LedgerHistory + --logging <- forComponent "LedgerHistory" + pure $ LedgerHistory { setTip = \p -> do - s <- readIORef store - writeIORef store $ Map.insert lastPointKey (serialize p) s + push tipsStack p + -- s <- readIORef store + -- writeIORef store $ Map.insert lastPointKey (serialize p) s , getTip = do - s <- readIORef store - mapM deserializeM $ Map.lookup lastPointKey s + pop tipsStack + -- s <- readIORef store + -- mapM deserializeM $ Map.lookup lastPointKey s , putBlock = \point blk -> do - s <- readIORef store - writeIORef store $ Map.insert (serialize point) (serialize blk) s + atomicModifyIORef' blockStorage (\blockList -> + if length blockList > 100 + then + let + (newStorage, _) = splitAt (100 `div` 2) blockList + in ((point, blk) : newStorage, ()) + else ((point, blk) : blockList, ()) + ) + -- push blocksStack (point, blk) + -- s <- readIORef store + -- writeIORef store $ Map.insert (serialize point) (serialize blk) s , getBlock = \point -> do - s <- readIORef store - mapM deserializeM $ Map.lookup (serialize point) s + s <- readIORef blockStorage + pure $ find (\(testP, _) -> point == testP) s <&> snd , pointExists = \point -> do s <- readIORef store pure $ Map.member (serialize point) s , dropBlock = \point -> do - s <- readIORef store - let - pkey = serialize point - exists = Map.member pkey s - if exists - then writeIORef store (Map.delete pkey s) $> True - else pure False + atomicModifyIORef' blockStorage (\blockList -> + (filter (\(testP, _) -> testP /= point) blockList, ()) + ) >> pure True + -- s <- readIORef store + -- let + -- pkey = serialize point + -- exists = Map.member pkey s + -- if exists + -- then writeIORef store (Map.delete pkey s) $> True + -- else pure False } attachLogging :: Monad m => Logging m -> LedgerHistory m -> LedgerHistory m diff --git a/ledger-sync/src/Spectrum/EventSource/Stream.hs b/ledger-sync/src/Spectrum/EventSource/Stream.hs index 5346b4c1..2b8b0cc3 100755 --- a/ledger-sync/src/Spectrum/EventSource/Stream.hs +++ b/ledger-sync/src/Spectrum/EventSource/Stream.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} module Spectrum.EventSource.Stream ( EventSource(..) , mkLedgerEventSource @@ -10,16 +12,18 @@ import RIO import Data.ByteString.Short ( toShort ) -import Control.Monad.Trans.Control - ( MonadBaseControl ) +import Ledger + ( TxId ) + +import qualified Data.Foldable as Foldable + import Control.Monad.IO.Class ( MonadIO ) import Control.Monad.Catch ( MonadThrow ) import Control.Monad ( join ) -import Control.Monad.Trans.Resource - ( MonadResource ) +import Data.Sequence.Strict import Streamly.Prelude as S @@ -36,10 +40,13 @@ import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Block ( Point ) +import Spectrum.EventSource.Data.Tx (MinimalTx(..), MinimalConfirmedTx (..)) + import Cardano.Ledger.Alonzo.TxSeq ( TxSeq(txSeqTxns) ) import qualified Cardano.Ledger.Block as Ledger import qualified Cardano.Crypto.Hash as CC +import Data.List import Spectrum.LedgerSync.Protocol.Client ( Block ) @@ -59,7 +66,7 @@ import Spectrum.EventSource.Types , ConcreteHash (ConcreteHash) ) import Spectrum.EventSource.Persistence.LedgerHistory - ( LedgerHistory (..), mkLedgerHistory ) + ( LedgerHistory (..), mkLedgerHistory, mkRuntimeLedgerHistory ) import Spectrum.EventSource.Data.TxEvent ( TxEvent(AppliedTx, UnappliedTx, PendingTx) ) import Spectrum.EventSource.Data.TxContext @@ -73,7 +80,8 @@ import Spectrum.LedgerSync.Data.MempoolUpdate import Spectrum.EventSource.Persistence.Config ( LedgerStoreConfig ) import Spectrum.Prelude.HigherKind - ( LiftK (liftK) ) + ( LiftK (liftK), type (~>) ) +import qualified Streamly.Internal.Data.Stream.IsStream as S newtype EventSource s m ctx = EventSource { upstream :: s m (TxEvent ctx) @@ -82,7 +90,8 @@ newtype EventSource s m ctx = EventSource mkLedgerEventSource :: forall f m s env. ( Monad f - , MonadResource f + , MonadIO f + , MonadThrow f , LiftK m f , IsStream s , Monad (s m) @@ -93,14 +102,15 @@ mkLedgerEventSource , HasType LedgerStoreConfig env ) => LedgerSync m + -> m ~> f -> f (EventSource s m 'LedgerCtx) -mkLedgerEventSource lsync = do - mklog@MakeLogging{..} <- askContext +mkLedgerEventSource lsync fToM = do + MakeLogging{..} <- askContext :: f (MakeLogging f m) EventSourceConfig{startAt} <- askContext - lhcong <- askContext + -- lhcong <- askContext logging <- forComponent "LedgerEventSource" - persistence <- mkLedgerHistory mklog lhcong + persistence <- fToM mkRuntimeLedgerHistory liftK $ seekToBeginning logging persistence lsync startAt pure $ EventSource @@ -110,7 +120,6 @@ mkLedgerEventSource lsync = do mkMempoolTxEventSource :: forall f m s env. ( Monad f - , MonadResource f , IsStream s , Monad (s m) , MonadAsync m @@ -151,7 +160,6 @@ processUpdate ( IsStream s , Monad (s m) , MonadIO m - , MonadBaseControl IO m , MonadThrow m ) => Logging m @@ -161,37 +169,35 @@ processUpdate processUpdate _ LedgerHistory{..} - (RollForward (BlockBabbage (ShelleyBlock (Ledger.Block (Praos.Header hBody _) txs) hHash))) = + (RollForward block@(BlockBabbage (ShelleyBlock (Ledger.Block (Praos.Header hBody _) txs) hHash)) _) = let txs' = txSeqTxns txs slotNo = Praos.hbSlotNo hBody point = ConcretePoint slotNo (ConcreteHash ch) where ch = OneEraHash . toShort . CC.hashToBytes . unShelleyHash $ hHash - in S.before (setTip point) - $ S.fromFoldable txs' & S.map (AppliedTx . fromBabbageLedgerTx hHash slotNo) + txsParsed = txs' <&> fromBabbageLedgerTx hHash slotNo + txsIds = Foldable.toList (txsParsed <&> (\(MinimalLedgerTx MinimalConfirmedTx{..}) -> txId)) :: [TxId] + parsedTxs = txsParsed <&> AppliedTx + in S.before (setTip point >> putBlock point (BlockLinks point txsIds)) $ S.fromFoldable parsedTxs processUpdate logging lh (RollBackward point) = streamUnappliedTxs logging lh point -processUpdate Logging{..} _ upd = S.before (errorM $ "Cannot process update " <> show upd) mempty +processUpdate Logging{..} _ upd = S.before (errorM $ "Cannot process update " <> show upd) (S.fromList []) processMempoolUpdate :: forall s m. ( IsStream s , MonadIO m - , MonadBaseControl IO m - , MonadThrow m ) => Logging m -> MempoolUpdate Block -> s m (TxEvent 'MempoolCtx) processMempoolUpdate _ (NewTx (GenTxBabbage (ShelleyTx _ x)) slot) = S.fromList [PendingTx $ fromMempoolBabbageLedgerTx x slot] -processMempoolUpdate Logging{..} _ = S.before (errorM @String "Cannot process mempool update") mempty +processMempoolUpdate Logging{..} _ = S.before (errorM @String "Cannot process mempool update") $ S.fromList [] streamUnappliedTxs :: forall s m. ( IsStream s , Monad (s m) , MonadIO m - , MonadBaseControl IO m - , MonadThrow m ) => Logging m -> LedgerHistory m @@ -209,15 +215,19 @@ streamUnappliedTxs Logging{..} LedgerHistory{..} point = join $ S.fromEffect $ d let emitTxs = S.fromFoldable (Prelude.reverse txIds <&> UnappliedTx) -- unapply txs in reverse order if toPoint prevPoint == point then emitTxs - else emitTxs <> rollbackOne prevPoint - Nothing -> mempty - tipM <- getTip - case tipM of - Just tip -> - if knownPoint - then infoM ("Rolling back to point " <> show point) $> rollbackOne tip - else errorM ("An attempt to roll back to an unknown point " <> show point) $> mempty - Nothing -> pure mempty + else S.append emitTxs (rollbackOne prevPoint) + Nothing -> S.fromList [] + if knownPoint + then do + tipM <- getTip + case tipM of + Just tip -> infoM ("Rolling back to point " <> show point) $> rollbackOne tip + Nothing -> errorM ("An attempt to roll back to an unknown point. (Empty tipM) " <> show point) $> S.fromList [] + else errorM ("An attempt to roll back to an unknown point " <> show point) $> S.fromList [] + -- tipM <- getTip + -- case tipM of + -- Just tip -> + -- Nothing -> pure mempty seekToBeginning :: Monad m diff --git a/ledger-sync/src/Spectrum/LedgerSync.hs b/ledger-sync/src/Spectrum/LedgerSync.hs index 5fa8fd05..fa49b59b 100755 --- a/ledger-sync/src/Spectrum/LedgerSync.hs +++ b/ledger-sync/src/Spectrum/LedgerSync.hs @@ -36,12 +36,12 @@ import Spectrum.LedgerSync.Data.LedgerUpdate import qualified Spectrum.LedgerSync.Data.LedgerUpdate as Update import qualified Spectrum.LedgerSync.Data.MempoolUpdate as MempoolUpdate import Spectrum.LedgerSync.Protocol.Data.ChainSync - ( RequestNextResponse(RollBackward, RollForward, block, point), + ( RequestNextResponse(RollBackward, RollForward, block, point, tip), RequestNext(RequestNext), ChainSyncResponse(RequestNextRes, FindIntersectRes), ChainSyncRequest(RequestNextReq, FindIntersectReq), FindIntersect(FindIntersect), - FindIntersectResponse (IntersectionFound) ) + FindIntersectResponse (IntersectionFound)) import Ouroboros.Consensus.Block ( StandardHash ) @@ -55,8 +55,7 @@ import Ouroboros.Consensus.Cardano.Block ( GenTx ) import Spectrum.LedgerSync.Config - ( NetworkParameters(NetworkParameters, slotsPerEpoch, networkMagic), - NodeSocketConfig(..) ) + ( NetworkParameters(NetworkParameters, slotsPerEpoch, networkMagic), NodeSocketConfig(..)) import Spectrum.LedgerSync.Exception ( ChainSyncInitFailed(ChainSyncInitFailed) ) import Spectrum.LedgerSync.Protocol.ChainSync @@ -93,18 +92,14 @@ mkLedgerSync , MonadMask m , MonadST m , MonadIO m - , MonadReader env m - , HasType NodeSocketConfig env - , HasType NetworkParameters env - , HasType (MakeLogging m m) env ) => UnliftIO m -> Tracer m TraceClient + -> MakeLogging m m + -> NodeSocketConfig + -> NetworkParameters -> m (LedgerSync m) -mkLedgerSync unliftIO tr = do - MakeLogging{..} <- askContext - NodeSocketConfig{nodeSocketPath, maxInFlight} <- askContext - NetworkParameters{slotsPerEpoch,networkMagic} <- askContext +mkLedgerSync unliftIO tr MakeLogging{..} NodeSocketConfig{..} NetworkParameters{..} = do l@Logging{..} <- forComponent "LedgerSync" (outQ, inQ) <- atomically $ (,) <$> newTQueue <*> newTQueue @@ -173,7 +168,7 @@ tryPull' outQ inQ = do atomically $ tryReadTQueue inQ <&> (<&> extractUpdate) extractUpdate :: ChainSyncResponse block -> LedgerUpdate block -extractUpdate (RequestNextRes RollForward{block}) = Update.RollForward block +extractUpdate (RequestNextRes RollForward{block, tip}) = Update.RollForward block tip extractUpdate (RequestNextRes RollBackward{point}) = Update.RollBackward point extractUpdate _ = undefined diff --git a/ledger-sync/src/Spectrum/LedgerSync/Data/LedgerUpdate.hs b/ledger-sync/src/Spectrum/LedgerSync/Data/LedgerUpdate.hs index 5b00a885..55633154 100755 --- a/ledger-sync/src/Spectrum/LedgerSync/Data/LedgerUpdate.hs +++ b/ledger-sync/src/Spectrum/LedgerSync/Data/LedgerUpdate.hs @@ -1,9 +1,9 @@ module Spectrum.LedgerSync.Data.LedgerUpdate where -import Ouroboros.Consensus.Block - ( Point ) +import Ouroboros.Network.Block + ( Point (..), Tip (..) ) data LedgerUpdate block - = RollForward block + = RollForward block (Tip block) | RollBackward (Point block) deriving (Eq, Show) diff --git a/nix/pkgs/haskell/haskell.nix b/nix/pkgs/haskell/haskell.nix index 8724a2dd..e5424271 100644 --- a/nix/pkgs/haskell/haskell.nix +++ b/nix/pkgs/haskell/haskell.nix @@ -43,7 +43,7 @@ let "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; "https://github.com/input-output-hk/plutus-apps"."593ffafa59dd30ad28cfaf144c526c66328595d2" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; - "https://github.com/ergolabs/cardano-dex-contracts"."2fb44f444897d84e313ceb4d3d467441385802dd" = "Kih0IS6Ty3EnXlgqAyF04nWIWJAnHOEVfraebh5RsNI="; + "https://github.com/ergolabs/cardano-dex-contracts"."7850574a9b7f3e33cd7fc16f5fcdbbf0c8de68df" = "1jzh8o3SdkZflVLLglT45iCcmgDSAg6b1P7fTwwmgPM="; "https://github.com/ergolabs/hlog"."19dfa3a6e696a3f63fc3539cd6b7a3fc4d999853" = "Lvmj1oLuXmktrboXh/BrXqLPf8FxSCXIf99GnBXu0Bk="; "https://github.com/daleiz/rocksdb-haskell"."109af08f95b40f458d4933e3725ecb3e59337c39" = "1i1ya491fapa0g96527krarv0w0iybizqcz518741iw06hhpikiy"; }; diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 4db0c728..513febad 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -19,6 +19,7 @@ import qualified NetworkAPI.Service as Network import NetworkAPI.Types import WalletAPI.Utxos import WalletAPI.Vault +import Cardano.Crypto.DSIGN.SchnorrSecp256k1 data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index e2555f14..feaf36ec 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -111,6 +111,7 @@ library cardano-ledger-shelley, cardano-ledger-core, cardano-ledger-shelley-ma, + cardano-crypto-class, cardano-ledger-byron, cardano-ledger-babbage, ouroboros-consensus, diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index 3d5f9211..531600ee 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -93,7 +93,7 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d let entriesLeft = Explorer.total utxoBatch - (offset + limit) if entriesLeft > 0 - then fetchUtxos (offset + limit) limit + then pure () -- fetchUtxos (offset + limit) limit else pure () extractAssets v = Set.fromList (flattenValue v <&> (\(cs, tn, _) -> (cs, tn))) From 0cdf6ab45d3b2d12c6aec51af667c0bfcc085358 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 20 Jul 2023 21:08:34 +0200 Subject: [PATCH 04/50] fix pool parsing --- dex-core/src/ErgoDex/ScriptsValidators.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dex-core/src/ErgoDex/ScriptsValidators.hs b/dex-core/src/ErgoDex/ScriptsValidators.hs index d1459004..f56e012a 100644 --- a/dex-core/src/ErgoDex/ScriptsValidators.hs +++ b/dex-core/src/ErgoDex/ScriptsValidators.hs @@ -41,7 +41,7 @@ parsePool Logging{..} ScriptsValidators{poolValidator} out@FullTxOut{..} = do let pool = parseFromLedger out :: Maybe (OnChain Pool) poolAddress = mkValidatorAddress poolValidator - if fullTxOutAddress == poolAddress + if (PV2.addressCredential fullTxOutAddress) == (PV2.addressCredential poolAddress) then case pool of Just a -> do infoM ("Pool found in: " ++ show out) From 48a7ab076823062b7159dfe411a2c054187bc82b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 20 Jul 2023 21:29:00 +0200 Subject: [PATCH 05/50] add debug --- dex-core/src/ErgoDex/ScriptsValidators.hs | 4 ++-- submit-api/test/Main.hs | 8 +++++++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/dex-core/src/ErgoDex/ScriptsValidators.hs b/dex-core/src/ErgoDex/ScriptsValidators.hs index f56e012a..21d2bbbe 100644 --- a/dex-core/src/ErgoDex/ScriptsValidators.hs +++ b/dex-core/src/ErgoDex/ScriptsValidators.hs @@ -44,12 +44,12 @@ parsePool Logging{..} ScriptsValidators{poolValidator} out@FullTxOut{..} = do if (PV2.addressCredential fullTxOutAddress) == (PV2.addressCredential poolAddress) then case pool of Just a -> do - infoM ("Pool found in: " ++ show out) + infoM ("Pool found in: " ++ show out ++ ". Out address:" ++ show fullTxOutAddress ++ ". pool address: " ++ show poolAddress) pure $ Just $ Confirmed out a _ -> do infoM ("Pool not found in: " ++ show out) pure Nothing - else pure Nothing + else infoM ("Pool not found in: " ++ show out ++ ". Out address:" ++ show fullTxOutAddress ++ ". pool address: " ++ show poolAddress) >> pure Nothing mkScriptsValidators :: (MonadIO m) => ScriptsConfig -> m ScriptsValidators mkScriptsValidators ScriptsConfig{..} = do diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 3b4b316c..5dbca7e0 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main where import qualified Data.Text.Encoding as E @@ -8,9 +10,13 @@ import Test.Tasty.HUnit import Spec.Transaction import System.Exit (exitFailure) import Control.Monad (unless) +import CardanoTx.Address main :: IO () -main = defaultMain tests +main = do + print $ show $ readShellyAddress "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + print $ show $ readShellyAddress "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" + --defaultMain tests tests = testGroup "SubmitApi" [ buildTxBodyTests From c7d67ab6ae50ef2ec9b6e0542a9831e4b536ab5b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 20 Jul 2023 21:48:32 +0200 Subject: [PATCH 06/50] fix swap op operation --- dex-core/src/ErgoDex/Amm/PoolActions.hs | 2 +- dex-core/src/ErgoDex/ScriptsValidators.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 8e336b73..ab38e496 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -103,7 +103,7 @@ runSwap' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerTok 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)) + when (poolReservesX pool * 2 <= lqBound pool) (Left $ InsufficientPoolLqForSwap (poolId pool)) let exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen diff --git a/dex-core/src/ErgoDex/ScriptsValidators.hs b/dex-core/src/ErgoDex/ScriptsValidators.hs index 21d2bbbe..f56e012a 100644 --- a/dex-core/src/ErgoDex/ScriptsValidators.hs +++ b/dex-core/src/ErgoDex/ScriptsValidators.hs @@ -44,12 +44,12 @@ parsePool Logging{..} ScriptsValidators{poolValidator} out@FullTxOut{..} = do if (PV2.addressCredential fullTxOutAddress) == (PV2.addressCredential poolAddress) then case pool of Just a -> do - infoM ("Pool found in: " ++ show out ++ ". Out address:" ++ show fullTxOutAddress ++ ". pool address: " ++ show poolAddress) + infoM ("Pool found in: " ++ show out) pure $ Just $ Confirmed out a _ -> do infoM ("Pool not found in: " ++ show out) pure Nothing - else infoM ("Pool not found in: " ++ show out ++ ". Out address:" ++ show fullTxOutAddress ++ ". pool address: " ++ show poolAddress) >> pure Nothing + else pure Nothing mkScriptsValidators :: (MonadIO m) => ScriptsConfig -> m ScriptsValidators mkScriptsValidators ScriptsConfig{..} = do From 5efbb44fc0d5f1a30da1071482de629b5a3dabcf Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 23 Jul 2023 17:09:09 +0200 Subject: [PATCH 07/50] update pool uplc --- cabal.project | 2 +- nix/pkgs/haskell/haskell.nix | 2 +- submit-api/test/Main.hs | 355 +++++++++++++++++++++++++++++++++-- 3 files changed, 343 insertions(+), 16 deletions(-) diff --git a/cabal.project b/cabal.project index ef1d1ff6..ff6f7669 100644 --- a/cabal.project +++ b/cabal.project @@ -313,7 +313,7 @@ source-repository-package source-repository-package type: git location: https://github.com/ergolabs/cardano-dex-contracts - tag: 7850574a9b7f3e33cd7fc16f5fcdbbf0c8de68df + tag: 3a1e67fb856b73838ddcd6108e73909c9c4769e8 subdir: cardano-dex-contracts-offchain diff --git a/nix/pkgs/haskell/haskell.nix b/nix/pkgs/haskell/haskell.nix index e5424271..80117903 100644 --- a/nix/pkgs/haskell/haskell.nix +++ b/nix/pkgs/haskell/haskell.nix @@ -43,7 +43,7 @@ let "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; "https://github.com/input-output-hk/plutus-apps"."593ffafa59dd30ad28cfaf144c526c66328595d2" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; - "https://github.com/ergolabs/cardano-dex-contracts"."7850574a9b7f3e33cd7fc16f5fcdbbf0c8de68df" = "1jzh8o3SdkZflVLLglT45iCcmgDSAg6b1P7fTwwmgPM="; + "https://github.com/ergolabs/cardano-dex-contracts"."3a1e67fb856b73838ddcd6108e73909c9c4769e8" = "Z/mlhsyPE5uVg7y6g/sOl9Y7gfA4cIxBIdky8cnXceE="; "https://github.com/ergolabs/hlog"."19dfa3a6e696a3f63fc3539cd6b7a3fc4d999853" = "Lvmj1oLuXmktrboXh/BrXqLPf8FxSCXIf99GnBXu0Bk="; "https://github.com/daleiz/rocksdb-haskell"."109af08f95b40f458d4933e3725ecb3e59337c39" = "1i1ya491fapa0g96527krarv0w0iybizqcz518741iw06hhpikiy"; }; diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 5dbca7e0..7d507f44 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -1,25 +1,352 @@ +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE RecordWildCards #-} module Main where import qualified Data.Text.Encoding as E import Test.Tasty import Test.Tasty.HUnit - -import Spec.Transaction -import System.Exit (exitFailure) -import Control.Monad (unless) +import PlutusTx.Builtins.Internal hiding (fst) +import PlutusTx +import ErgoDex.Contracts.Pool import CardanoTx.Address +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Lazy as LBS +import Codec.Serialise (serialise, deserialise) +import Data.Aeson as Json ( encode ) +import qualified Data.Text.Encoding as E +import qualified Data.ByteString.Base16 as Hex +import Plutus.Script.Utils.V2.Scripts +import qualified Plutus.V2.Ledger.Api as PlutusV2 +import qualified Data.Text as T +import Plutus.V1.Ledger.Value (AssetClass(..), assetClassValueOf, flattenValue, CurrencySymbol(..), TokenName(..)) +import Plutus.V1.Ledger.Api +import ErgoDex.PValidators +import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema)) +import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2) +import qualified Plutus.V1.Ledger.Scripts as Plutus +import qualified Cardano.Api as C +import qualified Plutus.Script.Utils.V2.Address as PV2 +import Cardano.Api (scriptDataToJson) +import Cardano.Api.Shelley ( fromPlutusData ) +import WalletAPI.TrustStore (importTrustStoreFromCardano, SecretFile (SecretFile), KeyPass (KeyPass)) +import qualified Ledger as PV2 +import CardanoTx.Address (readShellyAddress) +import Plutus.Script.Utils.V1.Address (mkValidatorAddress) +import Hedgehog.Internal.Show (Value(Integer)) + + +data TokenInfo = TokenInfo + { curSymbol :: String + , tokenName :: String + } deriving Eq + +instance Show TokenInfo where + show TokenInfo{..} = curSymbol ++ "." ++ tokenName + +adaTokenInfo :: TokenInfo +adaTokenInfo = TokenInfo "" "" + +isAda :: TokenInfo -> Bool +isAda ti = ti == adaTokenInfo + +data PoolInfo = PoolInfo + { name :: String + , tokenX :: TokenInfo + , tokenY :: TokenInfo + , tokenNft :: TokenInfo + , tokenLP :: TokenInfo + , lqBound :: Integer + , authKeys :: [String] + , threshold :: Integer + , initialXQty :: Integer + , initialYQty :: Integer + , allowStaking :: Bool + } + +lqInitQty = 9223372036854775807 + +workDir :: String +workDir = "/home/bromel/test-mainnet-pools/" + +mintingPolicyNamePostfix :: String +mintingPolicyNamePostfix = "_mintingPolicy" + +stakingScriptNamePostfix :: String +stakingScriptNamePostfix = "_stakingScript" + +poolDatumPostfix :: String +poolDatumPostfix = "_poolDatum" + +uplcExtension :: String +uplcExtension = ".uplc" + +plutusExtension :: String +plutusExtension = ".plutus" + +jsonExtension :: String +jsonExtension = ".json" + +uplcPolicyPath :: PoolInfo -> String +uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ uplcExtension + +plutusPolicyPath :: PoolInfo -> String +plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension + +uplcStakingScriptPath :: String -> String +uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension + +plutusStakingScriptPath :: String -> String +plutusStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ plutusExtension + +poolDatumPath :: PoolInfo -> String +poolDatumPath PoolInfo{..} = workDir ++ name ++ poolDatumPostfix ++ jsonExtension + +poolMainnetServerDatumPath :: String -> PoolInfo -> String +poolMainnetServerDatumPath mainnetWorkDir PoolInfo{..} = mainnetWorkDir ++ name ++ poolDatumPostfix ++ jsonExtension + +dq = "\"" main :: IO () main = do - print $ show $ readShellyAddress "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" - print $ show $ readShellyAddress "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" - --defaultMain tests - -tests = testGroup "SubmitApi" - [ buildTxBodyTests - , buildTxBodyContentTests - , buildBalancedTxTests - ] \ No newline at end of file + -- defaultMain tests + let + wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" + wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" + + mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] + + signaturesThreshold = 2 + + lqQty = 9223372036854775807 + + snekPool = PoolInfo + { name = "snekPool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f20534e454b5f4e4654" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f20534e454b5f4c51" + , lqBound = 1000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 4000000 + , initialYQty = 4000 + , allowStaking = True + } + sundaePool = PoolInfo + { name = "sundaePool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "9a9693a9a37912a5097918f97918d15240c92ab729a0b7c4aa144d77" "53554e444145" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f53554e4441455f4e4654" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415F53554E4441455F4C51" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 10000000 + , initialYQty = 1000000 + , allowStaking = True + } + snekSundaePool = PoolInfo + { name = "snekSundaePool" + , tokenX = TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" + , tokenY = TokenInfo "9a9693a9a37912a5097918f97918d15240c92ab729a0b7c4aa144d77" "53554e444145" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "534E454B5F53554E4441455F4E4654" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "534E454B5F53554E4441455F4C51" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 900 + , initialYQty = 3000000 + , allowStaking = False + } + pools = [snekPool, sundaePool, snekSundaePool] + + -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus + + -- convertUplcMintingPolicy `traverse` pools + + -- Step 1.5 (optional) + + -- convertUplcStakingScript wallet2PubKeyHash + + -- Step 2. Datums creation. Will produce output for cardano-cli. Also necessary to copy all datums from test to mainnet machine + + -- createDatumJson `traverse` pools + + -- Step 3. Require manual steps for creation staking certs + -- Also we cannot retrive original min utxo value for inline datums. So, set it manually + -- More Also, we cannot determine change. So, set it manually too + + -- let + -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" + -- -- on mainnet machine + -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" + + -- bootstrapAddressString = "" + -- bootstrapAddressVKeyPath = "" + + -- minUtxoValueForPool = 3223960 + + -- res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools + + -- folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res + + -- putStr folded + + -- end + + testJson + + pool <- poolValidator + swap <- swapValidator + redeem <- redeemValidator + deposit <- depositValidator + + print $ mkValidatorAddress pool + print $ mkValidatorAddress swap + print $ mkValidatorAddress redeem + print $ mkValidatorAddress deposit + + print $ readShellyAddress "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + + pure () + +-- poolDatum = PoolConfig spectrumTokenNFTClass spectrumTokenAClass spectrumTokenBClass spectrumTokenLPClass 995 + +-- poolDatumData = toData poolDatum + +-- datumStr = (T.decodeUtf8 . Hex.encode $ (LBS.toStrict $ serialise $ poolDatumData)) + +--- Pool creation stuff --- + +-- return cardano-cli string for pool and lp charge for user +poolCLICreationOutput :: PoolInfo -> String -> String -> Integer -> String -> String +poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxoValue origDatumWorkDir = + let + adaValue = if isAda tokenX then show initialXQty else show minUtxoValue + tokenXValue = if isAda tokenX then "" else "+" ++ dq ++ show initialXQty ++ " " ++ show tokenX ++ dq + tokenYValue = "+" ++ dq ++ show initialYQty ++ " " ++ show tokenY ++ dq + tokenNftValue = "+" ++ dq ++ "1 " ++ show tokenNft ++ dq + + charge = floor . sqrt . fromIntegral $ (initialXQty * initialYQty) + + tokenLpValue = "+" ++ dq ++ show (lqInitQty - charge) ++ " " ++ show tokenLP ++ dq + + address = if allowStaking then poolAddressWithStaking else poolAddress + + toCardanoCliPoolValue = "--tx-out " ++ address ++ "+" ++ adaValue ++ tokenXValue ++ tokenYValue ++ tokenNftValue ++ tokenLpValue ++ " \\" + + toCardanoCliDatum = "--tx-out-inline-datum-file " ++ poolMainnetServerDatumPath origDatumWorkDir pi ++ " \\" + + in toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum + +--- Datum creation stuff --- + +createDatumJson :: PoolInfo -> IO () +createDatumJson pi@PoolInfo{..} = do + let + convertedNft = tokenInfo2CS tokenNft + convertedX = tokenInfo2CS tokenX + convertedY = tokenInfo2CS tokenY + convertedLP = tokenInfo2CS tokenLP + + policies <- + if allowStaking + then do + mpPolicy <- getPoolMintingPolicy pi + let + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash mpPolicy + mpCS = CurrencySymbol mpPolicyHash + pure [mpCS] + else pure [] + + let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound + + writeDatumToJson pi poolConfig + pure () + +writeDatumToJson :: PoolInfo -> PoolConfig -> IO () +writeDatumToJson pi poolDatum = + LBS.writeFile (poolDatumPath pi) (Json.encode + . scriptDataToJson ScriptDataJsonDetailedSchema + . fromPlutusData + . toData + $ poolDatum ) + +testJson :: IO () +testJson = + print (Json.encode + . scriptDataToJson ScriptDataJsonDetailedSchema + . fromPlutusData + . toData + $ (0 :: Integer) ) + +--- Minting policies stuff --- + +convertUplcMintingPolicy :: PoolInfo -> IO () +convertUplcMintingPolicy pi@PoolInfo{..} = + if allowStaking + then do + bytes <- BS.readFile (uplcPolicyPath pi) + let + shortBS = SBS.toShort bytes + scr :: PlutusScript PlutusScriptV2 + scr = PlutusScriptSerialised shortBS + writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr + pure () + else pure () + +getPoolMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyPath pi) + let + script = deserialise (LBS.fromStrict bytes) + pure (PlutusV2.MintingPolicy script) + +--- Staking scripts stuff --- + +convertUplcStakingScript :: String -> IO () +convertUplcStakingScript pkh = do + bytes <- BS.readFile (uplcStakingScriptPath pkh) + let + shortBS = SBS.toShort bytes + scr :: PlutusScript PlutusScriptV2 + scr = PlutusScriptSerialised shortBS + writeFileTextEnvelope (plutusStakingScriptPath pkh) Nothing scr + pure () + +tokenInfo2CS :: TokenInfo -> AssetClass +tokenInfo2CS TokenInfo{..} = + let + convertedCS = CurrencySymbol $ BuiltinByteString $ mkByteString $ T.pack curSymbol + convertedTN = TokenName $ BuiltinByteString $ mkByteString $ T.pack tokenName + in AssetClass (convertedCS, convertedTN) + +textToPubKeyHash :: String -> PubKeyHash +textToPubKeyHash = PubKeyHash . BuiltinByteString . mkByteString . T.pack + +mkByteString :: T.Text -> BS.ByteString +mkByteString input = unsafeFromEither (Hex.decode . E.encodeUtf8 $ input) + +unsafeFromEither :: (Show b) => Either b a -> a +unsafeFromEither (Left err) = Prelude.error ("Err:" ++ show err) +unsafeFromEither (Right value) = value + +-- writeDataDatum2 :: FilePath -> IO () +-- writeDataDatum2 file = do +-- LBS.writeFile file (Json.encode +-- . scriptDataToJson ScriptDataJsonDetailedSchema +-- . fromPlutusData +-- . toData +-- $ (poolDatum) ) + +-- tests = testGroup "SubmitApi" +-- [ buildTxBodyTests +-- , buildTxBodyContentTests +-- , buildBalancedTxTests +-- ] \ No newline at end of file From 988719ba8a11acd057db8870b4504c49dec63ec3 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 23 Jul 2023 17:27:48 +0200 Subject: [PATCH 08/50] fix deps --- cabal.project | 2 +- dex-core/test/Spec/Pool.hs | 2 +- nix/pkgs/haskell/haskell.nix | 2 +- submit-api/test/Main.hs | 13 +++++-------- 4 files changed, 8 insertions(+), 11 deletions(-) diff --git a/cabal.project b/cabal.project index ff6f7669..e49a7e07 100644 --- a/cabal.project +++ b/cabal.project @@ -313,7 +313,7 @@ source-repository-package source-repository-package type: git location: https://github.com/ergolabs/cardano-dex-contracts - tag: 3a1e67fb856b73838ddcd6108e73909c9c4769e8 + tag: b4330de32e2d8be821a8a4fd3fd2d24508c280d7 subdir: cardano-dex-contracts-offchain diff --git a/dex-core/test/Spec/Pool.hs b/dex-core/test/Spec/Pool.hs index be4592f5..2139f70f 100644 --- a/dex-core/test/Spec/Pool.hs +++ b/dex-core/test/Spec/Pool.hs @@ -80,7 +80,7 @@ initialLiquidityTests = testGroup "InitialLiquidity" initialLiquidityAmount poolLq (Amount 10, Amount 11) @?= Right (AssetAmount poolLq 11) ] -poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum [] 0 +poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum sufficientInitDepositX = Amount 800 diff --git a/nix/pkgs/haskell/haskell.nix b/nix/pkgs/haskell/haskell.nix index 80117903..101c8f6b 100644 --- a/nix/pkgs/haskell/haskell.nix +++ b/nix/pkgs/haskell/haskell.nix @@ -43,7 +43,7 @@ let "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; "https://github.com/input-output-hk/plutus-apps"."593ffafa59dd30ad28cfaf144c526c66328595d2" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; - "https://github.com/ergolabs/cardano-dex-contracts"."3a1e67fb856b73838ddcd6108e73909c9c4769e8" = "Z/mlhsyPE5uVg7y6g/sOl9Y7gfA4cIxBIdky8cnXceE="; + "https://github.com/ergolabs/cardano-dex-contracts"."b4330de32e2d8be821a8a4fd3fd2d24508c280d7" = "exJoEIagnfPYqW3Tj96/Q/A/dR9c2jW5KPSahXfazfg="; "https://github.com/ergolabs/hlog"."19dfa3a6e696a3f63fc3539cd6b7a3fc4d999853" = "Lvmj1oLuXmktrboXh/BrXqLPf8FxSCXIf99GnBXu0Bk="; "https://github.com/daleiz/rocksdb-haskell"."109af08f95b40f458d4933e3725ecb3e59337c39" = "1i1ya491fapa0g96527krarv0w0iybizqcz518741iw06hhpikiy"; }; diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 7d507f44..0fbb6a79 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -200,19 +200,16 @@ main = do -- end - testJson - pool <- poolValidator swap <- swapValidator redeem <- redeemValidator deposit <- depositValidator - print $ mkValidatorAddress pool - print $ mkValidatorAddress swap - print $ mkValidatorAddress redeem - print $ mkValidatorAddress deposit - - print $ readShellyAddress "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + let + shortBS = SBS.toShort $ LBS.toStrict $ serialise (unValidatorScript pool) + scr :: PlutusScript PlutusScriptV2 + scr = PlutusScriptSerialised shortBS + writeFileTextEnvelope "/home/bromel/projects/cardano-dex-sdk-haskell/submit-api/pool.plutus" Nothing scr pure () From c86d2dc8a9c564d68057fb34ba2b8aae0d71b411 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Tue, 25 Jul 2023 12:07:19 +0200 Subject: [PATCH 09/50] add debug --- dex-core/src/ErgoDex/Amm/PoolActions.hs | 137 +++++-- .../src/SubmitAPI/Internal/Balancing.hs | 4 + submit-api/test/Main.hs | 348 +----------------- 3 files changed, 121 insertions(+), 368 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index ab38e496..42f20a46 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -28,6 +28,8 @@ import qualified ErgoDex.Contracts.Pool as P import qualified ErgoDex.Contracts.Proxy.Order as O import ErgoDex.Contracts.Types import CardanoTx.Models +import System.Logging.Hlog (Logging (Logging)) +import Plutus.V1.Ledger.Value (Value) data OrderExecErr = PriceTooHigh @@ -46,6 +48,30 @@ data AmmValidators ver = AmmValidators , redeemV :: RedeemValidator ver } +-- debug order info +data OrderInfo = RedeemInfo { redeem :: Redeem + , redeemOut :: FullTxOut + , burnLqValue :: Maybe Value + , realExFee :: Maybe Integer + , outXAndY :: Maybe (AssetAmount X, AssetAmount Y) + , exFee :: Maybe Integer + } + | SwapInfo { swap :: Swap + , swapOut :: FullTxOut + , realQuoteOutput :: AssetAmount Quote + , realExFee :: Maybe Integer + , realRV :: Maybe Value + } + | DepositInfo { deposit :: Deposit + , depositOut :: FullTxOut + , inXAndY :: Maybe (Amount X, Amount Y) + , netXAndY :: Maybe (Amount X, Amount Y) + , rewardLPAndCharge :: Maybe (Amount Liquidity, (Amount X, Amount Y)) + , mintLqValue :: Maybe Value + , depositExFee :: Maybe (Amount Lovelace) + } + deriving (Show) + fetchValidatorsV1 :: MonadIO m => m (AmmValidators V1) fetchValidatorsV1 = AmmValidators @@ -55,9 +81,9 @@ fetchValidatorsV1 = <*> fetchRedeemValidatorV1 data PoolActions = PoolActions - { runSwap :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool) - , runDeposit :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool) - , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool) + { runSwap :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + , runDeposit :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) } mkPoolActions :: PaymentPubKeyHash -> AmmValidators V1 -> PoolActions @@ -94,16 +120,22 @@ runSwap' -> [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) - -> Either OrderExecErr (TxCandidate, Predicted Pool) -runSwap' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerToken{..}, ..}) (poolOut, pool) = do + -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) +runSwap' executorPkh pv sv refInputs (OnChain swapOut s@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 (poolReservesX pool * 2 <= lqBound pool) (Left $ InsufficientPoolLqForSwap (poolId pool)) + initSwapInfo = SwapInfo + { swap = s + , swapOut = swapOut + , realQuoteOutput = quoteOutput + , realExFee = Nothing + , realRV = Nothing + } + when (swapPoolId /= poolId pool) (Left $ (PoolMismatch swapPoolId (poolId pool), initSwapInfo)) + when (getAmount quoteOutput < swapMinQuoteOut) (Left (PriceTooHigh, initSwapInfo)) + when (poolReservesX pool * 2 <= lqBound pool) (Left $ (InsufficientPoolLqForSwap (poolId pool), initSwapInfo)) let exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen @@ -118,24 +150,32 @@ runSwap' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerTok where initValue = fullTxOutValue swapOut residualValue = - initValue + initValue <> assetClassValue (unCoin swapBase) (negate $ unAmount swapBaseIn) -- Remove Base input <> Ada.lovelaceValueOf (negate exFee) -- Remove Batcher Fee rewardValue = assetAmountValue quoteOutput <> residualValue - txCandidate = TxCandidate - { txCandidateInputs = inputs - , txCandidateRefIns = refInputs - , txCandidateOutputs = [nextPoolOut, rewardOut] - , txCandidateValueMint = mempty - , txCandidateMintInputs = mempty - , txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing - , txCandidateValidRange = Interval.always - , txCandidateSigners = mempty + fullSwapInfo = SwapInfo + { swap = s + , swapOut = swapOut + , realQuoteOutput = quoteOutput + , realExFee = Just exFee + , realRV = Just (txOutCandidateValue rewardOut) } - Right (txCandidate, pp) + txCandidate = TxCandidate + { txCandidateInputs = inputs + , txCandidateRefIns = refInputs + , txCandidateOutputs = [nextPoolOut, rewardOut] + , txCandidateValueMint = mempty + , txCandidateMintInputs = mempty + , txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing + , txCandidateValidRange = Interval.always + , txCandidateSigners = mempty + } + + Right (txCandidate, pp, fullSwapInfo) runDeposit' :: PaymentPubKeyHash @@ -144,9 +184,20 @@ runDeposit' -> [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) - -> Either OrderExecErr (TxCandidate, Predicted Pool) -runDeposit' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do - when (depositPoolId /= poolId) (Left $ PoolMismatch depositPoolId poolId) + -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) +runDeposit' executorPkh pv dv refInputs (OnChain depositOut d@Deposit{..}) (poolOut, pool@Pool{..}) = do + let + initDepositInfo = DepositInfo + { deposit = d + , depositOut = depositOut + , inXAndY = Nothing + , netXAndY = Nothing + , rewardLPAndCharge = Nothing + , mintLqValue = Nothing + , depositExFee = Nothing + } + + when (depositPoolId /= poolId) (Left $ ((PoolMismatch depositPoolId poolId), initDepositInfo)) let inputs = mkOrderInputs P.Deposit pv dv (PoolIn poolOut) (OrderIn depositOut) @@ -154,7 +205,7 @@ runDeposit' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOu bimap entryAmount entryAmount $ if assetEntryClass (fst depositPair) == unCoin poolCoinX then depositPair - else swap depositPair + else Data.Tuple.swap depositPair where entryAmount (AssetEntry (_, v)) = Amount v exFee = unExFee depositExFee @@ -191,6 +242,16 @@ runDeposit' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOu <> Ada.lovelaceValueOf (negate $ unAmount exFee) -- Remove Fee rewardValue = residualValue <> mintLqValue <> alignmentValue + finalDepositInfo = DepositInfo + { deposit = d + , depositOut = depositOut + , inXAndY = Just (inX, inY) + , netXAndY = Just (netInX, netInY) + , rewardLPAndCharge = Just $ rewardLp pool (netInX, netInY) + , mintLqValue = Just mintLqValue + , depositExFee = Just exFee + } + txCandidate = TxCandidate { txCandidateInputs = inputs , txCandidateRefIns = refInputs @@ -202,7 +263,7 @@ runDeposit' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOu , txCandidateSigners = mempty } - Right (txCandidate, pp) + Right (txCandidate, pp, finalDepositInfo) runRedeem' :: PaymentPubKeyHash @@ -211,9 +272,18 @@ runRedeem' -> [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) - -> Either OrderExecErr (TxCandidate, Predicted Pool) -runRedeem' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do - when (redeemPoolId /= poolId) (Left $ PoolMismatch redeemPoolId poolId) + -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) +runRedeem' executorPkh pv rv refInputs (OnChain redeemOut r@Redeem{..}) (poolOut, pool@Pool{..}) = do + let + initRedeemInfo = RedeemInfo + { redeem = r + , redeemOut = redeemOut + , burnLqValue = Nothing + , realExFee = Nothing + , outXAndY = Nothing + , exFee = Nothing + } + when (redeemPoolId /= poolId) (Left $ ((PoolMismatch redeemPoolId poolId), initRedeemInfo)) let inputs = mkOrderInputs P.Redeem pv rv (PoolIn poolOut) (OrderIn redeemOut) @@ -242,6 +312,15 @@ runRedeem' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, rewardValue = assetAmountValue outX <> assetAmountValue outY <> residualValue + finalRedeemInfo = RedeemInfo + { redeem = r + , redeemOut = redeemOut + , burnLqValue = Just burnLqValue + , realExFee = Just exFee + , outXAndY = Just (sharesAmount pool redeemLqIn) + , exFee = Just exFee + } + txCandidate = TxCandidate { txCandidateInputs = inputs , txCandidateRefIns = refInputs @@ -253,4 +332,4 @@ runRedeem' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, , txCandidateSigners = mempty } - Right (txCandidate, pp) + Right (txCandidate, pp, finalRedeemInfo) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 4cc0696a..8b865f71 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -15,6 +15,7 @@ import Data.Ratio import Cardano.Api import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, ReferenceScript (..), fromShelleyLovelace) import qualified Cardano.Ledger.Coin as Ledger +import Debug.Trace makeTransactionBodyAutoBalance :: forall era mode. @@ -271,8 +272,11 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -> ProtocolParameters -> Either TxBodyErrorAutoBalance () checkMinUTxOValue txout@(TxOut addr v _ _) pparams' = do + traceM $ "Going to check min utxo for box: " ++ show txout minUTxO <- first TxBodyErrorMinUTxOMissingPParams $ calculateMinimumUTxO era txout pparams' + traceM $ "Min utxo is: " ++ show minUTxO + traceM $ "Lovelace in box is: " ++ show (txOutValueToLovelace v) let chargeBoxWillBeMerged = addr == changeaddr if txOutValueToLovelace v >= selectLovelace minUTxO || chargeBoxWillBeMerged then Right () diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 0fbb6a79..3b4b316c 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -1,349 +1,19 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} module Main where import qualified Data.Text.Encoding as E import Test.Tasty import Test.Tasty.HUnit -import PlutusTx.Builtins.Internal hiding (fst) -import PlutusTx -import ErgoDex.Contracts.Pool -import CardanoTx.Address -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Hex -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Short as SBS -import qualified Data.ByteString.Lazy as LBS -import Codec.Serialise (serialise, deserialise) -import Data.Aeson as Json ( encode ) -import qualified Data.Text.Encoding as E -import qualified Data.ByteString.Base16 as Hex -import Plutus.Script.Utils.V2.Scripts -import qualified Plutus.V2.Ledger.Api as PlutusV2 -import qualified Data.Text as T -import Plutus.V1.Ledger.Value (AssetClass(..), assetClassValueOf, flattenValue, CurrencySymbol(..), TokenName(..)) -import Plutus.V1.Ledger.Api -import ErgoDex.PValidators -import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema)) -import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2) -import qualified Plutus.V1.Ledger.Scripts as Plutus -import qualified Cardano.Api as C -import qualified Plutus.Script.Utils.V2.Address as PV2 -import Cardano.Api (scriptDataToJson) -import Cardano.Api.Shelley ( fromPlutusData ) -import WalletAPI.TrustStore (importTrustStoreFromCardano, SecretFile (SecretFile), KeyPass (KeyPass)) -import qualified Ledger as PV2 -import CardanoTx.Address (readShellyAddress) -import Plutus.Script.Utils.V1.Address (mkValidatorAddress) -import Hedgehog.Internal.Show (Value(Integer)) - -data TokenInfo = TokenInfo - { curSymbol :: String - , tokenName :: String - } deriving Eq - -instance Show TokenInfo where - show TokenInfo{..} = curSymbol ++ "." ++ tokenName - -adaTokenInfo :: TokenInfo -adaTokenInfo = TokenInfo "" "" - -isAda :: TokenInfo -> Bool -isAda ti = ti == adaTokenInfo - -data PoolInfo = PoolInfo - { name :: String - , tokenX :: TokenInfo - , tokenY :: TokenInfo - , tokenNft :: TokenInfo - , tokenLP :: TokenInfo - , lqBound :: Integer - , authKeys :: [String] - , threshold :: Integer - , initialXQty :: Integer - , initialYQty :: Integer - , allowStaking :: Bool - } - -lqInitQty = 9223372036854775807 - -workDir :: String -workDir = "/home/bromel/test-mainnet-pools/" - -mintingPolicyNamePostfix :: String -mintingPolicyNamePostfix = "_mintingPolicy" - -stakingScriptNamePostfix :: String -stakingScriptNamePostfix = "_stakingScript" - -poolDatumPostfix :: String -poolDatumPostfix = "_poolDatum" - -uplcExtension :: String -uplcExtension = ".uplc" - -plutusExtension :: String -plutusExtension = ".plutus" - -jsonExtension :: String -jsonExtension = ".json" - -uplcPolicyPath :: PoolInfo -> String -uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ uplcExtension - -plutusPolicyPath :: PoolInfo -> String -plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension - -uplcStakingScriptPath :: String -> String -uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension - -plutusStakingScriptPath :: String -> String -plutusStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ plutusExtension - -poolDatumPath :: PoolInfo -> String -poolDatumPath PoolInfo{..} = workDir ++ name ++ poolDatumPostfix ++ jsonExtension - -poolMainnetServerDatumPath :: String -> PoolInfo -> String -poolMainnetServerDatumPath mainnetWorkDir PoolInfo{..} = mainnetWorkDir ++ name ++ poolDatumPostfix ++ jsonExtension - -dq = "\"" +import Spec.Transaction +import System.Exit (exitFailure) +import Control.Monad (unless) main :: IO () -main = do - -- defaultMain tests - let - wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" - wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" - - mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] - - signaturesThreshold = 2 - - lqQty = 9223372036854775807 - - snekPool = PoolInfo - { name = "snekPool" - , tokenX = adaTokenInfo - , tokenY = TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f20534e454b5f4e4654" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f20534e454b5f4c51" - , lqBound = 1000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 4000000 - , initialYQty = 4000 - , allowStaking = True - } - sundaePool = PoolInfo - { name = "sundaePool" - , tokenX = adaTokenInfo - , tokenY = TokenInfo "9a9693a9a37912a5097918f97918d15240c92ab729a0b7c4aa144d77" "53554e444145" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415f53554e4441455f4e4654" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "4144415F53554E4441455F4C51" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 10000000 - , initialYQty = 1000000 - , allowStaking = True - } - snekSundaePool = PoolInfo - { name = "snekSundaePool" - , tokenX = TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" - , tokenY = TokenInfo "9a9693a9a37912a5097918f97918d15240c92ab729a0b7c4aa144d77" "53554e444145" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "534E454B5F53554E4441455F4E4654" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "534E454B5F53554E4441455F4C51" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 900 - , initialYQty = 3000000 - , allowStaking = False - } - pools = [snekPool, sundaePool, snekSundaePool] - - -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus - - -- convertUplcMintingPolicy `traverse` pools - - -- Step 1.5 (optional) - - -- convertUplcStakingScript wallet2PubKeyHash - - -- Step 2. Datums creation. Will produce output for cardano-cli. Also necessary to copy all datums from test to mainnet machine - - -- createDatumJson `traverse` pools - - -- Step 3. Require manual steps for creation staking certs - -- Also we cannot retrive original min utxo value for inline datums. So, set it manually - -- More Also, we cannot determine change. So, set it manually too - - -- let - -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" - -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" - -- -- on mainnet machine - -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" - - -- bootstrapAddressString = "" - -- bootstrapAddressVKeyPath = "" - - -- minUtxoValueForPool = 3223960 - - -- res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools - - -- folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res - - -- putStr folded - - -- end - - pool <- poolValidator - swap <- swapValidator - redeem <- redeemValidator - deposit <- depositValidator - - let - shortBS = SBS.toShort $ LBS.toStrict $ serialise (unValidatorScript pool) - scr :: PlutusScript PlutusScriptV2 - scr = PlutusScriptSerialised shortBS - writeFileTextEnvelope "/home/bromel/projects/cardano-dex-sdk-haskell/submit-api/pool.plutus" Nothing scr - - pure () - --- poolDatum = PoolConfig spectrumTokenNFTClass spectrumTokenAClass spectrumTokenBClass spectrumTokenLPClass 995 - --- poolDatumData = toData poolDatum - --- datumStr = (T.decodeUtf8 . Hex.encode $ (LBS.toStrict $ serialise $ poolDatumData)) - ---- Pool creation stuff --- - --- return cardano-cli string for pool and lp charge for user -poolCLICreationOutput :: PoolInfo -> String -> String -> Integer -> String -> String -poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxoValue origDatumWorkDir = - let - adaValue = if isAda tokenX then show initialXQty else show minUtxoValue - tokenXValue = if isAda tokenX then "" else "+" ++ dq ++ show initialXQty ++ " " ++ show tokenX ++ dq - tokenYValue = "+" ++ dq ++ show initialYQty ++ " " ++ show tokenY ++ dq - tokenNftValue = "+" ++ dq ++ "1 " ++ show tokenNft ++ dq - - charge = floor . sqrt . fromIntegral $ (initialXQty * initialYQty) - - tokenLpValue = "+" ++ dq ++ show (lqInitQty - charge) ++ " " ++ show tokenLP ++ dq - - address = if allowStaking then poolAddressWithStaking else poolAddress - - toCardanoCliPoolValue = "--tx-out " ++ address ++ "+" ++ adaValue ++ tokenXValue ++ tokenYValue ++ tokenNftValue ++ tokenLpValue ++ " \\" - - toCardanoCliDatum = "--tx-out-inline-datum-file " ++ poolMainnetServerDatumPath origDatumWorkDir pi ++ " \\" - - in toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum - ---- Datum creation stuff --- - -createDatumJson :: PoolInfo -> IO () -createDatumJson pi@PoolInfo{..} = do - let - convertedNft = tokenInfo2CS tokenNft - convertedX = tokenInfo2CS tokenX - convertedY = tokenInfo2CS tokenY - convertedLP = tokenInfo2CS tokenLP - - policies <- - if allowStaking - then do - mpPolicy <- getPoolMintingPolicy pi - let - (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash mpPolicy - mpCS = CurrencySymbol mpPolicyHash - pure [mpCS] - else pure [] - - let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound - - writeDatumToJson pi poolConfig - pure () - -writeDatumToJson :: PoolInfo -> PoolConfig -> IO () -writeDatumToJson pi poolDatum = - LBS.writeFile (poolDatumPath pi) (Json.encode - . scriptDataToJson ScriptDataJsonDetailedSchema - . fromPlutusData - . toData - $ poolDatum ) - -testJson :: IO () -testJson = - print (Json.encode - . scriptDataToJson ScriptDataJsonDetailedSchema - . fromPlutusData - . toData - $ (0 :: Integer) ) - ---- Minting policies stuff --- - -convertUplcMintingPolicy :: PoolInfo -> IO () -convertUplcMintingPolicy pi@PoolInfo{..} = - if allowStaking - then do - bytes <- BS.readFile (uplcPolicyPath pi) - let - shortBS = SBS.toShort bytes - scr :: PlutusScript PlutusScriptV2 - scr = PlutusScriptSerialised shortBS - writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr - pure () - else pure () - -getPoolMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy -getPoolMintingPolicy pi = do - bytes <- BS.readFile (uplcPolicyPath pi) - let - script = deserialise (LBS.fromStrict bytes) - pure (PlutusV2.MintingPolicy script) - ---- Staking scripts stuff --- - -convertUplcStakingScript :: String -> IO () -convertUplcStakingScript pkh = do - bytes <- BS.readFile (uplcStakingScriptPath pkh) - let - shortBS = SBS.toShort bytes - scr :: PlutusScript PlutusScriptV2 - scr = PlutusScriptSerialised shortBS - writeFileTextEnvelope (plutusStakingScriptPath pkh) Nothing scr - pure () - -tokenInfo2CS :: TokenInfo -> AssetClass -tokenInfo2CS TokenInfo{..} = - let - convertedCS = CurrencySymbol $ BuiltinByteString $ mkByteString $ T.pack curSymbol - convertedTN = TokenName $ BuiltinByteString $ mkByteString $ T.pack tokenName - in AssetClass (convertedCS, convertedTN) - -textToPubKeyHash :: String -> PubKeyHash -textToPubKeyHash = PubKeyHash . BuiltinByteString . mkByteString . T.pack - -mkByteString :: T.Text -> BS.ByteString -mkByteString input = unsafeFromEither (Hex.decode . E.encodeUtf8 $ input) - -unsafeFromEither :: (Show b) => Either b a -> a -unsafeFromEither (Left err) = Prelude.error ("Err:" ++ show err) -unsafeFromEither (Right value) = value - --- writeDataDatum2 :: FilePath -> IO () --- writeDataDatum2 file = do --- LBS.writeFile file (Json.encode --- . scriptDataToJson ScriptDataJsonDetailedSchema --- . fromPlutusData --- . toData --- $ (poolDatum) ) +main = defaultMain tests --- tests = testGroup "SubmitApi" --- [ buildTxBodyTests --- , buildTxBodyContentTests --- , buildBalancedTxTests --- ] \ No newline at end of file +tests = testGroup "SubmitApi" + [ buildTxBodyTests + , buildTxBodyContentTests + , buildBalancedTxTests + ] \ No newline at end of file From f70b66a889091fd93ded501bdc625104e0e80461 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sat, 29 Jul 2023 15:38:42 +0200 Subject: [PATCH 10/50] add unsafe order execution --- dex-core/src/ErgoDex/Amm/PoolActions.hs | 226 +++++++- .../src/SubmitAPI/Internal/Balancing.hs | 37 +- .../src/SubmitAPI/Internal/Transaction.hs | 21 + submit-api/submit-api.cabal | 6 + submit-api/test/Main.hs | 496 +++++++++++++++++- 5 files changed, 762 insertions(+), 24 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 42f20a46..3ffa72d1 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -81,16 +81,22 @@ fetchValidatorsV1 = <*> fetchRedeemValidatorV1 data PoolActions = PoolActions - { runSwap :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) - , runDeposit :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) - , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + { runSwapWithDebug :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + , runDepositWithDebug :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + , runRedeemWithDebug :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) + , runSwap :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) + , runDeposit :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) + , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) } mkPoolActions :: PaymentPubKeyHash -> AmmValidators V1 -> PoolActions mkPoolActions executorPkh AmmValidators{..} = PoolActions - { runSwap = runSwap' executorPkh poolV swapV - , runDeposit = runDeposit' executorPkh poolV depositV - , runRedeem = runRedeem' executorPkh poolV redeemV + { runSwapWithDebug = runSwapWithDebug' executorPkh poolV swapV + , runDepositWithDebug = runDepositWithDebug' executorPkh poolV depositV + , runRedeemWithDebug = runRedeemWithDebug' executorPkh poolV redeemV + , runSwap = runSwapUnsafe' executorPkh poolV swapV + , runDeposit = runDepositUnsafe' executorPkh poolV depositV + , runRedeem = runRedeemUnsafe' executorPkh poolV redeemV } newtype PoolIn = PoolIn FullTxOut @@ -113,7 +119,203 @@ mkOrderInputs action (PoolValidator pv) ov' (PoolIn poolOut) (OrderIn orderOut) orderIn = mkScriptTxIn orderOut ov (Redeemer $ toBuiltinData $ O.OrderRedeemer poolIx orderIx 1 O.Apply) in Set.fromList [poolIn, orderIn] -runSwap' +runSwapUnsafe' + :: PaymentPubKeyHash + -> PoolValidator V1 + -> SwapValidator V1 + -> [FullTxOut] + -> OnChain Swap + -> (FullTxOut, Pool) + -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) +runSwapUnsafe' 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 (poolReservesX pool * 2 <= lqBound pool) (Left $ InsufficientPoolLqForSwap (poolId pool)) + + let + fee = 300000 + exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen + rewardAddr = pubKeyHashAddress (PaymentPubKeyHash swapRewardPkh) swapRewardSPkh + rewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = rewardValue + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + where + initValue = fullTxOutValue swapOut + residualValue = + initValue + <> assetClassValue (unCoin swapBase) (negate $ unAmount swapBaseIn) -- Remove Base input + <> Ada.lovelaceValueOf (negate exFee) -- Remove Batcher Fee + + rewardValue = assetAmountValue quoteOutput <> residualValue + + executorRewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = Ada.lovelaceValueOf (exFee - fee) + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + + txCandidate = TxCandidate + { txCandidateInputs = inputs + , txCandidateRefIns = refInputs + , txCandidateOutputs = [nextPoolOut, rewardOut, executorRewardOut] + , txCandidateValueMint = mempty + , txCandidateMintInputs = mempty + , txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing + , txCandidateValidRange = Interval.always + , txCandidateSigners = mempty + } + + Right (txCandidate, pp, exFee - fee) + +runDepositUnsafe' + :: PaymentPubKeyHash + -> PoolValidator V1 + -> DepositValidator V1 + -> [FullTxOut] + -> OnChain Deposit + -> (FullTxOut, Pool) + -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) +runDepositUnsafe' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do + when (depositPoolId /= poolId) (Left $ PoolMismatch depositPoolId poolId) + let + fee = 300000 + inputs = mkOrderInputs P.Deposit pv dv (PoolIn poolOut) (OrderIn depositOut) + + (inX, inY) = + bimap entryAmount entryAmount $ + if assetEntryClass (fst depositPair) == unCoin poolCoinX + then depositPair + else Data.Tuple.swap depositPair + where entryAmount (AssetEntry (_, v)) = Amount v + + exFee = unExFee depositExFee + + (netInX, netInY) + | isAda poolCoinX = (inX - retagAmount exFee - retagAmount adaCollateral, inY) + | isAda poolCoinY = (inX, inY - retagAmount exFee - retagAmount adaCollateral) + | otherwise = (inX, inY) + + (unlockedLq, (Amount changeX, Amount changeY)) = rewardLp pool (netInX, netInY) + + alignmentValue = + assetClassValue (unCoin poolCoinY) changeY + <> assetClassValue (unCoin poolCoinX) changeX + + pp@(Predicted nextPoolOut _) = applyDeposit pv pool (netInX, netInY) + + mintLqValue = assetAmountValue (AssetAmount poolCoinLq unlockedLq) + + rewardAddr = pubKeyHashAddress (PaymentPubKeyHash depositRewardPkh) depositRewardSPkh + rewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = rewardValue + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + where + initValue = fullTxOutValue depositOut + residualValue = + initValue + <> assetClassValue (unCoin poolCoinX) (negate $ unAmount netInX) -- Remove X net input + <> assetClassValue (unCoin poolCoinY) (negate $ unAmount netInY) -- Remove Y net input + <> Ada.lovelaceValueOf (negate $ unAmount exFee) -- Remove Fee + rewardValue = residualValue <> mintLqValue <> alignmentValue + + executorRewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = Ada.lovelaceValueOf (unAmount exFee - fee) + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + + txCandidate = TxCandidate + { txCandidateInputs = inputs + , txCandidateRefIns = refInputs + , txCandidateOutputs = [nextPoolOut, rewardOut, executorRewardOut] + , txCandidateValueMint = mempty + , txCandidateMintInputs = mempty + , txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing + , txCandidateValidRange = Interval.always + , txCandidateSigners = mempty + } + + Right (txCandidate, pp, unAmount exFee - fee) + +runRedeemUnsafe' + :: PaymentPubKeyHash + -> PoolValidator V1 + -> RedeemValidator V1 + -> [FullTxOut] + -> OnChain Redeem + -> (FullTxOut, Pool) + -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) +runRedeemUnsafe' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do + when (redeemPoolId /= poolId) (Left $ PoolMismatch redeemPoolId poolId) + let + fee = 300000 + + 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 + rewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = rewardValue + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + where + (outX, outY) = sharesAmount pool redeemLqIn + initValue = fullTxOutValue redeemOut + negatedExFe = Ada.lovelaceValueOf . negate $ exFee + residualValue = + initValue + <> burnLqValue + <> negatedExFe -- Remove LQ input and ExFee + + rewardValue = assetAmountValue outX <> assetAmountValue outY <> residualValue + + executorRewardOut = + TxOutCandidate + { txOutCandidateAddress = rewardAddr + , txOutCandidateValue = Ada.lovelaceValueOf (exFee - fee) + , txOutCandidateDatum = EmptyDatum + , txOutCandidateRefScript = Nothing + } + + txCandidate = TxCandidate + { txCandidateInputs = inputs + , txCandidateRefIns = refInputs + , txCandidateOutputs = [nextPoolOut, rewardOut, executorRewardOut] + , txCandidateValueMint = mempty + , txCandidateMintInputs = mempty + , txCandidateChangePolicy = Just $ ReturnTo $ pubKeyHashAddress executorPkh Nothing + , txCandidateValidRange = Interval.always + , txCandidateSigners = mempty + } + + Right (txCandidate, pp, exFee - fee) + +runSwapWithDebug' :: PaymentPubKeyHash -> PoolValidator V1 -> SwapValidator V1 @@ -121,7 +323,7 @@ runSwap' -> OnChain Swap -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) -runSwap' executorPkh pv sv refInputs (OnChain swapOut s@Swap{swapExFee=ExFeePerToken{..}, ..}) (poolOut, pool) = do +runSwapWithDebug' executorPkh pv sv refInputs (OnChain swapOut s@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) @@ -177,7 +379,7 @@ runSwap' executorPkh pv sv refInputs (OnChain swapOut s@Swap{swapExFee=ExFeePerT Right (txCandidate, pp, fullSwapInfo) -runDeposit' +runDepositWithDebug' :: PaymentPubKeyHash -> PoolValidator V1 -> DepositValidator V1 @@ -185,7 +387,7 @@ runDeposit' -> OnChain Deposit -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) -runDeposit' executorPkh pv dv refInputs (OnChain depositOut d@Deposit{..}) (poolOut, pool@Pool{..}) = do +runDepositWithDebug' executorPkh pv dv refInputs (OnChain depositOut d@Deposit{..}) (poolOut, pool@Pool{..}) = do let initDepositInfo = DepositInfo { deposit = d @@ -265,7 +467,7 @@ runDeposit' executorPkh pv dv refInputs (OnChain depositOut d@Deposit{..}) (pool Right (txCandidate, pp, finalDepositInfo) -runRedeem' +runRedeemWithDebug' :: PaymentPubKeyHash -> PoolValidator V1 -> RedeemValidator V1 @@ -273,7 +475,7 @@ runRedeem' -> OnChain Redeem -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) -runRedeem' executorPkh pv rv refInputs (OnChain redeemOut r@Redeem{..}) (poolOut, pool@Pool{..}) = do +runRedeemWithDebug' executorPkh pv rv refInputs (OnChain redeemOut r@Redeem{..}) (poolOut, pool@Pool{..}) = do let initRedeemInfo = RedeemInfo { redeem = r diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 8b865f71..120d5e2f 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -7,7 +7,7 @@ import RIO (isJust) import Data.Bifunctor (first) import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, catMaybes) +import Data.Maybe (catMaybes) import Data.Functor ((<&>)) import Data.Set (Set) import Data.Ratio @@ -16,6 +16,37 @@ import Cardano.Api import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, ReferenceScript (..), fromShelleyLovelace) import qualified Cardano.Ledger.Coin as Ledger import Debug.Trace +import Control.FromSum + +makeTransactionBodyBalanceUnsafe + :: forall era. + IsShelleyBasedEra era + => TxBodyContent BuildTx era + -> AddressInEra era -- ^ Change address + -> Integer + -> Either TxBodyErrorAutoBalance (BalancedTxBody era) +makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue = do + let era' = cardanoEra + retColSup <- maybeToEitherOr (totalAndReturnCollateralSupportedInEra era') TxBodyErrorMissingParamMinUTxO -- incorrect error + let + fee = 300000 + reqAmt = 1300000 + totalCollateral = TxTotalCollateral retColSup (Lovelace reqAmt) + (retColl, reqCol) = + ( TxReturnCollateral + retColSup + (TxOut changeaddr (lovelaceToTxOutValue (Lovelace reqAmt)) TxOutDatumNone ReferenceScriptNone) + , totalCollateral + ) + explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ + txFeesExplicitInEra era' + txBody0 <- first TxBodyError $ makeTransactionBody txbodycontent + { txOuts = txOuts txbodycontent + , txFee = TxFeeExplicit explicitTxFees $ Lovelace fee + , txReturnCollateral = retColl + , txTotalCollateral = reqCol + } + return (BalancedTxBody txBody0 (TxOut changeaddr (lovelaceToTxOutValue (Lovelace changeValue)) TxOutDatumNone ReferenceScriptNone) (Lovelace fee)) makeTransactionBodyAutoBalance :: forall era mode. @@ -258,9 +289,9 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams | otherwise = do let chargeBoxWillBeMerged = isJust $ find (\(TxOut boxAddr _ _ _) -> boxAddr == changeaddr) outs if chargeBoxWillBeMerged - then + then Right () - else + else case checkMinUTxOValue (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) pparams of Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) -> Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance) diff --git a/submit-api/src/SubmitAPI/Internal/Transaction.hs b/submit-api/src/SubmitAPI/Internal/Transaction.hs index 3e9ab19b..d6172299 100644 --- a/submit-api/src/SubmitAPI/Internal/Transaction.hs +++ b/submit-api/src/SubmitAPI/Internal/Transaction.hs @@ -60,6 +60,27 @@ buildBalancedTx SystemEnv{..} refScriptsMap network defaultChangeAddr collateral absorbBalancingError (Left e) = throwM $ BalancingError $ T.pack $ displayError e absorbBalancingError (Right a) = pure a +buildBalancedTxUnsafe + :: (MonadThrow f) + => SystemEnv + -> Map P.Script C.TxIn + -> NetworkId + -> Sdk.ChangeAddress + -> Set.Set Sdk.FullCollateralTxIn + -> Sdk.TxCandidate + -> Integer + -> f (BalancedTxBody BabbageEra) +buildBalancedTxUnsafe SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} changeValue = do + txBody <- buildTxBodyContent pparams network refScriptsMap collateral txc + changeAddr <- absorbError $ case txCandidateChangePolicy of + Just (Sdk.ReturnTo addr) -> Interop.toCardanoAddressInEra network addr + _ -> Interop.toCardanoAddressInEra network $ Sdk.getAddress defaultChangeAddr + absorbBalancingError $ + Balancing.makeTransactionBodyBalanceUnsafe txBody changeAddr changeValue + where + absorbBalancingError (Left e) = throwM $ BalancingError $ T.pack $ displayError e + absorbBalancingError (Right a) = pure a + estimateTxFee :: (MonadThrow f) => ProtocolParameters diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index feaf36ec..f959a94c 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -90,6 +90,7 @@ library cardano-slotting, cardano-api, mtl, + from-sum, plutus-ledger, bytestring, aeson, @@ -134,8 +135,10 @@ test-suite submit-api-tests , base , HUnit , hedgehog + , rio , tasty , tasty-hunit + , transformers , tasty-hedgehog , aeson , text @@ -158,6 +161,9 @@ test-suite submit-api-tests , cardano-tx , network-api , wallet-api + , cardano-cli , serialise , cardano-dex-contracts-offchain , cardano-ledger-alonzo + , memory + , quickblue \ No newline at end of file diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 3b4b316c..86002f3a 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -1,19 +1,497 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} module Main where import qualified Data.Text.Encoding as E import Test.Tasty import Test.Tasty.HUnit +import PlutusTx.Builtins.Internal hiding (fst) +import PlutusTx +import ErgoDex.Contracts.Pool +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Hex +import qualified Plutus.V2.Ledger.Contexts as PV2L +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Lazy as LBS +import Codec.Serialise (serialise, deserialise) +import Data.Aeson as Json ( encode ) +import qualified Data.Text.Encoding as E +import qualified Data.ByteString.Base16 as Hex +import Plutus.Script.Utils.V2.Scripts +import qualified Plutus.V2.Ledger.Api as PlutusV2 +import qualified Data.Text as T +import Plutus.V1.Ledger.Value (AssetClass(..), assetClassValueOf, flattenValue, CurrencySymbol(..), TokenName(..)) +import Plutus.V1.Ledger.Api +import ErgoDex.PValidators +import Cardano.CLI.Shelley.Run.Transaction +import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema), InAnyCardanoEra (InAnyCardanoEra), EraInMode (BabbageEraInCardanoMode), IsShelleyBasedEra) +import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode)) +import qualified Plutus.V1.Ledger.Scripts as Plutus +import qualified Cardano.Api as C +import qualified Plutus.Script.Utils.V2.Address as PV2 +import Cardano.Api (scriptDataToJson) +import Data.ByteArray.Encoding (Base(..), convertToBase) +import Cardano.Api.Shelley ( fromPlutusData ) +import WalletAPI.TrustStore (importTrustStoreFromCardano, SecretFile (SecretFile), KeyPass (KeyPass), mkTrustStore) +import qualified Ledger as PV2 +import CardanoTx.Address (readShellyAddress) +import WalletAPI.Vault (Vault (getPaymentKeyHash), mkVault) +import qualified Explorer.Types as Explorer +import qualified Plutus.V1.Ledger.Api as P +import Cardano.Ledger.Alonzo.Data (Data(..)) +import qualified Plutus.V1.Ledger.Bytes as Data +import ErgoDex.Contracts.Proxy.Deposit (DepositConfig(..)) +import Plutus.V2.Ledger.Tx (OutputDatum(..)) +import Ledger.Ada (lovelaceValueOf) +import Ledger.Value (assetClassValue) +import qualified PlutusTx.AssocMap as Map +import qualified Plutus.V1.Ledger.Interval as Interval +import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction (Refund)) +import Control.Monad.IO.Class (MonadIO(liftIO)) +import RIO (lift, (&)) +import Control.Monad.Trans.Except (runExceptT) -import Spec.Transaction -import System.Exit (exitFailure) -import Control.Monad (unless) + +data TokenInfo = TokenInfo + { curSymbol :: String + , tokenName :: String + } deriving Eq + +instance Show TokenInfo where + show TokenInfo{..} = curSymbol ++ "." ++ tokenName + +adaTokenInfo :: TokenInfo +adaTokenInfo = TokenInfo "" "" + +isAda :: TokenInfo -> Bool +isAda ti = ti == adaTokenInfo + +data PoolInfo = PoolInfo + { name :: String + , tokenX :: TokenInfo + , tokenY :: TokenInfo + , tokenNft :: TokenInfo + , tokenLP :: TokenInfo + , lqBound :: Integer + , authKeys :: [String] + , threshold :: Integer + , initialXQty :: Integer + , initialYQty :: Integer + , allowStaking :: Bool + } + +lqInitQty = 9223372036854775807 + +workDir :: String +workDir = "/home/bromel/test-mainnet-pools/" + +mintingPolicyNamePostfix :: String +mintingPolicyNamePostfix = "_mintingPolicy" + +stakingScriptNamePostfix :: String +stakingScriptNamePostfix = "_stakingScript" + +poolDatumPostfix :: String +poolDatumPostfix = "_poolDatum" + +uplcExtension :: String +uplcExtension = ".uplc" + +plutusExtension :: String +plutusExtension = ".plutus" + +jsonExtension :: String +jsonExtension = ".json" + +uplcPolicyPath :: PoolInfo -> String +uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ uplcExtension + +plutusPolicyPath :: PoolInfo -> String +plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension + +uplcStakingScriptPath :: String -> String +uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension + +plutusStakingScriptPath :: String -> String +plutusStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ plutusExtension + +poolDatumPath :: PoolInfo -> String +poolDatumPath PoolInfo{..} = workDir ++ name ++ poolDatumPostfix ++ jsonExtension + +poolMainnetServerDatumPath :: String -> PoolInfo -> String +poolMainnetServerDatumPath mainnetWorkDir PoolInfo{..} = mainnetWorkDir ++ name ++ poolDatumPostfix ++ jsonExtension + +dq = "\"" main :: IO () -main = defaultMain tests +main = do + txFile + +txFile :: IO () +txFile = do + txFinal <- runExceptT $ readFileTx "/home/bromel/projects/cardano-dex-sdk-haskell/submit-api/test/txNormal.signed" + liftIO $ print (show (eraseLeft txFinal)) + pure () + +eraseRight :: Either a b -> Either a () +eraseRight (Right _) = Right () +eraseRight (Left l) = Left l + +eraseLeft :: Either a b -> Either () b +eraseLeft (Right l) = Right l +eraseLeft (Left _) = Left () + +test3 = do + deposit <- depositValidator + + let + depositAddress = PV2.mkValidatorAddress deposit + + inputAda = lovelaceValueOf 11929173 + + snekAssetClass = tokenInfo2CS $ TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" + inputSnek = assetClassValue snekAssetClass 10000 + + poolNft = tokenInfo2CS $ TokenInfo "4a27465112a39464e6dd5ee470c552ebb3cb42925d5ec04014967908" "534E454B5F4144415F4E4654" + poolLp = tokenInfo2CS $ TokenInfo "7bddf2c27f257eeeef3e892758b479e09c89a73642499797f2a97f3c" "534E454B5F4144415F4C51" + + inputDatum = DepositConfig + { poolNft = poolNft + , tokenA = tokenInfo2CS adaTokenInfo + , tokenB = snekAssetClass + , tokenLp = poolLp + , exFee = 1500000 + , rewardPkh = PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "719bee424a97b58b3dca88fe5da6feac6494aa7226f975f3506c5b25" + , stakePkh = Just $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "7846f6bb07f5b2825885e4502679e699b4e60a0c4609a46bc35454cd" + , collateralAda = 0 + } + + refundInput = PV2L.TxInInfo { + txInInfoOutRef = TxOutRef { + txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "818804916028d33eef09eb2c5dac47d2c38094eeba21daac65c1627afd82884d", + txOutRefIdx = 0 + }, + txInInfoResolved = PlutusV2.TxOut { + txOutAddress = depositAddress, + txOutValue = inputAda <> inputSnek, + txOutDatum = OutputDatum $ Datum $ toBuiltinData inputDatum, + txOutReferenceScript = Just $ scriptHash (unValidatorScript deposit) + } + } + + unknownReferenceInput = refundInput + + depositRefInputAda = lovelaceValueOf 1226634 + + depositReferenceInput = PV2L.TxInInfo { + txInInfoOutRef = TxOutRef { + txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "fc9e99fd12a13a137725da61e57a410e36747d513b965993d92c32c67df9259a", + txOutRefIdx = 0 + }, + txInInfoResolved = PlutusV2.TxOut { + txOutAddress = Address + (PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea") + (Just $ StakingHash $ PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "3f70ef0595dbc750d6575d814af8da0cdb53e778dae4895e85ef239e"), + txOutValue = depositRefInputAda, + txOutDatum = NoOutputDatum, + txOutReferenceScript = Nothing + } + } + + userTxOutAda = lovelaceValueOf 10452541 + + userTxOut = PlutusV2.TxOut { + txOutAddress = Address + (PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "21bcdaa800d642aa94d62ab43524de3481a7790b69172e7e3ef882ec") + (Just $ StakingHash $ PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "7846f6bb07f5b2825885e4502679e699b4e60a0c4609a46bc35454cd"), + txOutValue = userTxOutAda <> inputSnek, + txOutDatum = NoOutputDatum, + txOutReferenceScript = Nothing + } + + spendingRef = TxOutRef { + txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "818804916028d33eef09eb2c5dac47d2c38094eeba21daac65c1627afd82884d", + txOutRefIdx = 0 + } + + orderRedeemer = toBuiltinData $ OrderRedeemer 0 0 0 Refund + + txId = TxId $ BuiltinByteString $ mkByteString $ T.pack "349709cb602d3ae5405e8fba4888c4f31706345c183014efe1b5388447aadca8" + + ctx = PV2L.TxInfo + { txInfoInputs = [refundInput] -- ^ Transaction inputs + , txInfoReferenceInputs = [unknownReferenceInput, depositReferenceInput] -- ^ Transaction reference inputs + , txInfoOutputs = [userTxOut] -- ^ Transaction outputs + , txInfoFee = lovelaceValueOf 1476632 -- ^ The fee paid by this transaction. + , txInfoMint = lovelaceValueOf 0 -- ^ The 'Value' minted by this transaction. + , txInfoDCert = [] -- ^ Digests of certificates included in this transaction + , txInfoWdrl = Map.empty -- ^ Withdrawals + , txInfoValidRange = Interval.always -- ^ The valid range for the transaction. + , txInfoSignatories = [ + PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "21bcdaa800d642aa94d62ab43524de3481a7790b69172e7e3ef882ec", + PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "719bee424a97b58b3dca88fe5da6feac6494aa7226f975f3506c5b25" -- collateral signature + datum + ] -- ^ Signatures provided with the transaction, attested that they all signed the tx + , txInfoRedeemers = Map.fromList [(Spending spendingRef, Redeemer orderRedeemer)] + , txInfoData = Map.empty + , txInfoId = txId + -- ^ Hash of the pending transaction (excluding witnesses) + } + + print depositAddress + + print $ show $ toBuiltinData ctx + -- print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" + pure () + +test123 = do + let + trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") + vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO + + mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes + + pkh <- getPaymentKeyHash vault + + let + address = (mkPCred pkh) + + print address + + -- defaultMain tests + let + wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" + wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" + + mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] + + signaturesThreshold = 2 + + lqQty = 9223372036854775807 + + rabbitPool = PoolInfo + { name = "rabbitPool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6e6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6c71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 15000000 + , initialYQty = 15000000 + , allowStaking = True + } + goldfishPool = PoolInfo + { name = "goldfishPool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6e6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6c71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 15000000 + , initialYQty = 15000000000 + , allowStaking = True + } + rabbitFoldfishPool = PoolInfo + { name = "rabbitGoldfishPool" + , tokenX = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6E6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6C71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 1000000 + , initialYQty = 1000000 + , allowStaking = False + } + pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] + + -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus + + -- convertUplcMintingPolicy `traverse` pools + + -- Step 1.5 (optional) + + -- convertUplcStakingScript wallet2PubKeyHash + + -- Step 2. Datums creation. Will produce output for cardano-cli. Also necessary to copy all datums from test to mainnet machine + + -- createDatumJson `traverse` pools + + -- Step 3. Require manual steps for creation staking certs + -- Also we cannot retrive original min utxo value for inline datums. So, set it manually + -- More Also, we cannot determine change. So, set it manually too + + -- let + -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" + -- -- on mainnet machine + -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" + + -- bootstrapAddressString = "" + -- bootstrapAddressVKeyPath = "" + + -- minUtxoValueForPool = 3223960 + + -- res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools + + -- folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res + + -- putStr folded + + -- end + + --print $ readShellyAddress "addr1v8g2jvkr55vsqlteuu5x0052lgj3ak0ev5vs74dyu0fgahg92dth0" + + -- print $ readShellyAddress "addr1qxupdk69sdemdx80far0tsvrydz7zj67ydzxxujmv9srj3tcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsy8ugdz" + + print $ readShellyAddress "addr1qxy8aeh2e77hgtrevn4p459m7qsqswfnkxck26g2cuanh2ncgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqf8en8" + print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" + + -- let testData = "hgCYrxoAAyNhGQMsAQEZA+gZAjsAARkD6BlecQQBGQPoGCAaAAHKdhko6wQZWdgYZBlZ2BhkGVnYGGQZWdgYZBlZ2BhkGVnYGGQYZBhkGVnYGGQZTFEYIBoAAqz6GCAZtVEEGgADYxUZAf8AARoAAVw1GCAaAAeXdRk29AQCGgAC/5QaAAbqeBjcAAEBGQPoGW/2BAIaAAO9CBoAA07FGD4BGgAQLg8ZMSoBGgADLoAZAaUBGgAC2ngZA+gZzwYBGgABOjQYIBmo8RggGQPoGCAaAAE6rAEZ4UMEGQPoChoAAwIZGJwBGgADAhkYnAEaAAMgfBkB2QEaAAMwABkB/wEZzPMYIBn9QBggGf/VGCAZWB4YIBlAsxggGgABKt8YIBoAAv+UGgAG6ngY3AABARoAAQ+SGS2nAAEZ6rsYIBoAAv+UGgAG6ngY3AABARoAAv+UGgAG6ngY3AABARoAEbIsGgAF/d4AAhoADFBOGXcSBBoAHWr2GgABQlsEGgAEDGYABAAaAAFPqxggGgADI2EZAywBARmg3hggGgADPXYYIBl59BggGX+4GCAZqV0YIBl99xggGZWqGCAaAiOszAoaA3T2kxlKHwoaAlFehBmAswqCGgCYloAbAAAAAhhxGgBZBHFZBG4BAAAyMjIyMjIyMjIyMjIyMjIyMjIyMjIyIiUzMBUyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMlMzAvM3DpABABCZGRkZGSmZgaGbh1MzA0M3Dm60wNTA2ARSAAFIAAUgAkgABUzAlM3DmYFQBhgagPJABCpmBKZuvMDUAYwNQChUzAlM3DmZgZkRKZmBiACIAQmYAZm4AAJIAIwOQAUgAAFUgBBUzAlUzMDQzcOAEACKURUzMDQzcQAEACJmZmYEYB5gagOAAgBABgCiZmZmBGAeYGoDoAQAIAgAombiVMzA0M3EgBAAiAEIAJmBUAeYGoDYmZEZkYGxEpmYGYAIpQFTMwOTN15gdAAgBilETACMDsAE3UgAgBG6wwNTIwNzA3MDcwNzA3ABMDYBY3XGBqAyZmZmBGAQYGgDYAQAhutMDQBk3WmBoYGoC5mZmYEQA5gZgNgBABm60wMwGDdaYGZgaALGYE4BJgZAMmYEwBBgYgMmbgUg/v//////////ATMCUAcwMAFhYwMgAjApABN1RgWmBcAubqzIwLTAuMC8AEwLDAtABMC0AEzAmN1pgVADgFG6syMCowKzAsABMCkwKgATAqABMwIzdaYE4AoA5mRGRkZKZmBUZGRkpmYFpm4dIAIAITIyMlMzAwM3DpAAABClATN15unAEN04AJgZgBGBUACbqgBxMjIyUzMDAzcOkAEAEKUBM3Xm6cAQ3TgAmBmAEYFQAJuqAHMDAAIwJwATdUACIAQsZGRkZGSmZgXGbh0gAAAhMjIyMlMzAyM3DpAAABCZGRkZKZmBsZuHSACACFhM3SpAAAAmByAEYGAAJuqABMDMAEWMDUAIwLAATdUACYF4AImbpUgAgKTAxACMCgAE3VAAmBWYFhgWgAmBUYFgApurMjIyUzMCszcOkAEAELCpmYFZm483XGBYACAMJgWGBaYFwA4sYFwARgSgAm6oAEyMCkwKwATAoMCoAM3XGBMAUYEwBJmBCbrTAlABAEMCUAEwJAATAkAON1hgQgBG6wwIAAjAgMCAAEwIDAeAIMB4AEwHQATAcABMBsAEwGgATAZABMBkAQwGAARSYWIiIiM3EmbgzNwRm4EAQAMAIAEzANAGAFIiIiMjNwZm4JTMwFzIyUzAKM3Hm64wGjAbACN1xgNGA2ACJm483XGA0AEbrjAaABMBsAswGgBhM3AmbgQAQAwAhABAEAFMwDABgBSIzMBEAIAEAMUoGbpUgADMAE3UgBGYAJupACAIV0CRAQAiMjMwBAAzdcYBwAJuuMA4wDwATAPABIiMzMAQAJIAAjMzAFACSAAdabqwAQAyMAI3UgAkREZgFESmZgDgAiAKKmZgGmbrzAJMA4AEAYTAEMBEwDgARMAIwDwAQAVVz6XrgVXOkSmZgCmbiAAkgABYTMAMAIAEwASIlMzAFM3DgBJAACYAwAImYAZm4EAJIAIwBwASMjACIzACACABIwAiMwAgAgAVc0roVdERgBG6oAFVc8Gf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP/YeZ8AAAAB/9h5n9h5n5/YeZ/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/2Hmf2Hmf2HqfWBwHXgnrD6ieHcNGkbPFan9DfmCsXqZ7M48uF24g/9h6gP+iQKFAGgC2NddYHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej+hRFNORUsZJxDYe5/YeZ/YeZ9YHEonRlESo5Rk5t1e5HDFUuuzy0KSXV7AQBSWeQhMU05FS19BREFfTkZU/9h5n0BA/9h5n1gcJ5yQnzSOUz2lgIiY+H+aFLssPfu6zM1jHZJ6P0RTTkVL/9h5n1gce93ywn8lfu7vPoknWLR54JyJpzZCSZeX8ql/PEtTTkVLX0FEQV9MUf8aABbjYFgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJdh5n1gceEb2uwf1soJYheRQJnnmmbTmCgxGCaRrw1RUzf8A///YeoD///+f2Hmf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A/9h5n9h5n9h6n1gcB14J6w+onh3DRpGzxWp/Q35grF6mezOPLhduIP/YeoD/okChQBoAtjXXWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2Huf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP//2HqA///YeZ/YeZ/YeZ9YIPyemf0SoToTdyXaYeV6QQ42dH1RO5ZZk9ksMsZ9+SWa/wD/2Hmf2Hmf2HmfWBym4Zc+U6+AxHPK+yiCNYZPZiQNMF2c6d+ZISXq/9h5n9h5n9h5n1gcP3DvBZXbx1DWV12BSvjaDNtT53ja5Ilehe8jnv////+hQKFAGgC7K2TYeYDYeZ9YHAdeCesPqJ4dw0aRs8Vqf0N+YKxepnszjy4XbiD/////n9h5n9h5n9h5n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7P/YeZ/YeZ/YeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/////okChQBoAn5uEWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2HmA2HqA//+hQKFAGgAWmlOhQKFAAICg2Hmf2Hmf2HmA2HqA/9h5n9h7gNh6gP//n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7FgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJf+h2Hqf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A///YeZ8AAAAB/6DYeZ9YIDMW4vM4hWi8LBR8kV4+xSzqkd2A8PJeMjwpxJhhd4zB///Yep/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/////gggA" + -- plutusData = Data.from testData + + -- pool <- poolValidator + -- print (PV2.mkValidatorAddress pool) + -- swap <- swapValidator + -- print (PV2.mkValidatorAddress swap) + -- deposit <- depositValidator + -- print (PV2.mkValidatorAddress deposit) + -- redeem <- redeemValidator + -- print (PV2.mkValidatorAddress redeem) + + pure () + +-- poolDatum = PoolConfig spectrumTokenNFTClass spectrumTokenAClass spectrumTokenBClass spectrumTokenLPClass 995 + +-- poolDatumData = toData poolDatum + +-- datumStr = (T.decodeUtf8 . Hex.encode $ (LBS.toStrict $ serialise $ poolDatumData)) + +--- Pool creation stuff --- + +-- return cardano-cli string for pool and lp charge for user +poolCLICreationOutput :: PoolInfo -> String -> String -> Integer -> String -> String +poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxoValue origDatumWorkDir = + let + adaValue = if isAda tokenX then show initialXQty else show minUtxoValue + tokenXValue = if isAda tokenX then "" else "+" ++ dq ++ show initialXQty ++ " " ++ show tokenX ++ dq + tokenYValue = "+" ++ dq ++ show initialYQty ++ " " ++ show tokenY ++ dq + tokenNftValue = "+" ++ dq ++ "1 " ++ show tokenNft ++ dq + + charge = floor . sqrt . fromIntegral $ (initialXQty * initialYQty) + + tokenLpValue = "+" ++ dq ++ show (lqInitQty - charge) ++ " " ++ show tokenLP ++ dq + + address = if allowStaking then poolAddressWithStaking else poolAddress + + toCardanoCliPoolValue = "--tx-out " ++ address ++ "+" ++ adaValue ++ tokenXValue ++ tokenYValue ++ tokenNftValue ++ tokenLpValue ++ " \\" + + toCardanoCliDatum = "--tx-out-inline-datum-file " ++ poolMainnetServerDatumPath origDatumWorkDir pi ++ " \\" + + in toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum + +--- Datum creation stuff --- + +createDatumJson :: PoolInfo -> IO () +createDatumJson pi@PoolInfo{..} = do + let + convertedNft = tokenInfo2CS tokenNft + convertedX = tokenInfo2CS tokenX + convertedY = tokenInfo2CS tokenY + convertedLP = tokenInfo2CS tokenLP + + policies <- + if allowStaking + then do + mpPolicy <- getPoolMintingPolicy pi + let + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash mpPolicy + mpCS = CurrencySymbol mpPolicyHash + pure [mpCS] + else pure [] + + let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound + + writeDatumToJson pi poolConfig + pure () + +writeDatumToJson :: PoolInfo -> PoolConfig -> IO () +writeDatumToJson pi poolDatum = + LBS.writeFile (poolDatumPath pi) (Json.encode + . scriptDataToJson ScriptDataJsonDetailedSchema + . fromPlutusData + . toData + $ poolDatum ) + +--- Minting policies stuff --- + +convertUplcMintingPolicy :: PoolInfo -> IO () +convertUplcMintingPolicy pi@PoolInfo{..} = + if allowStaking + then do + bytes <- BS.readFile (uplcPolicyPath pi) + let + shortBS = SBS.toShort bytes + scr :: PlutusScript PlutusScriptV2 + scr = PlutusScriptSerialised shortBS + writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr + pure () + else pure () + +getPoolMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyPath pi) + let + script = deserialise (LBS.fromStrict bytes) + pure (PlutusV2.MintingPolicy script) + +--- Staking scripts stuff --- + +convertUplcStakingScript :: String -> IO () +convertUplcStakingScript pkh = do + bytes <- BS.readFile (uplcStakingScriptPath pkh) + let + shortBS = SBS.toShort bytes + scr :: PlutusScript PlutusScriptV2 + scr = PlutusScriptSerialised shortBS + writeFileTextEnvelope (plutusStakingScriptPath pkh) Nothing scr + pure () + +tokenInfo2CS :: TokenInfo -> AssetClass +tokenInfo2CS TokenInfo{..} = + let + convertedCS = CurrencySymbol $ BuiltinByteString $ mkByteString $ T.pack curSymbol + convertedTN = TokenName $ BuiltinByteString $ mkByteString $ T.pack tokenName + in AssetClass (convertedCS, convertedTN) + +textToPubKeyHash :: String -> PubKeyHash +textToPubKeyHash = PubKeyHash . BuiltinByteString . mkByteString . T.pack + +mkByteString :: T.Text -> BS.ByteString +mkByteString input = unsafeFromEither (Hex.decode . E.encodeUtf8 $ input) + +unsafeFromEither :: (Show b) => Either b a -> a +unsafeFromEither (Left err) = Prelude.error ("Err:" ++ show err) +unsafeFromEither (Right value) = value + +-- writeDataDatum2 :: FilePath -> IO () +-- writeDataDatum2 file = do +-- LBS.writeFile file (Json.encode +-- . scriptDataToJson ScriptDataJsonDetailedSchema +-- . fromPlutusData +-- . toData +-- $ (poolDatum) ) -tests = testGroup "SubmitApi" - [ buildTxBodyTests - , buildTxBodyContentTests - , buildBalancedTxTests - ] \ No newline at end of file +-- tests = testGroup "SubmitApi" +-- [ buildTxBodyTests +-- , buildTxBodyContentTests +-- , buildBalancedTxTests +-- ] \ No newline at end of file From 7d926a436f868914872614ec9aee28dfe052d5a2 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sat, 29 Jul 2023 16:11:15 +0200 Subject: [PATCH 11/50] add unsafe finalizeTx --- submit-api/src/SubmitAPI/Service.hs | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 513febad..d0abbba4 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -79,6 +79,31 @@ finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAsse signers <- mapM (\pkh -> getSigningKey pkh >>= maybe (throwM $ SignerNotFound pkh) pure) signatories pure $ Internal.signTx txb signers +finalizeTxUnsafe' + :: MonadThrow f + => CardanoNetwork f C.BabbageEra + -> C.NetworkId + -> Map P.Script C.TxIn + -> WalletOutputs f + -> Vault f + -> TxAssemblyConfig + -> Sdk.TxCandidate + -> Integer + -> f (C.Tx C.BabbageEra) +finalizeTxUnsafe' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do + sysenv <- getSystemEnv + collaterals <- selectCollaterals utxos sysenv refScriptsMap network conf txc + + (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue + let + allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) + signatories = allInputs >>= getPkh + where + getPkh Sdk.FullTxOut{fullTxOutAddress=P.Address (P.PubKeyCredential pkh) _} = [pkh] + getPkh _ = [] + signers <- mapM (\pkh -> getSigningKey pkh >>= maybe (throwM $ SignerNotFound pkh) pure) signatories + pure $ Internal.signTx txb signers + submitTx' :: Monad f => CardanoNetwork f C.BabbageEra -> C.Tx C.BabbageEra -> f C.TxId submitTx' CardanoNetwork{submitTx} tx = do submitTx tx From 07cecc47354a45363a3329b151c099c87a8b0cb4 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sat, 29 Jul 2023 16:16:26 +0200 Subject: [PATCH 12/50] fix Transactions --- submit-api/src/SubmitAPI/Service.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index d0abbba4..9f7ef588 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -24,6 +24,7 @@ import Cardano.Crypto.DSIGN.SchnorrSecp256k1 data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace , finalizeTx :: Sdk.TxCandidate -> f (C.Tx era) + , finalizeTxUnsafe :: Sdk.TxCandidate -> Integer -> f (C.Tx era) , submitTx :: C.Tx era -> f C.TxId } @@ -39,6 +40,7 @@ mkTransactions mkTransactions network networkId refScriptsMap utxos wallet conf = Transactions { estimateTxFee = estimateTxFee' network networkId refScriptsMap , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf + , finalizeTxUnsafe = finalizeTxUnsafe' network networkId refScriptsMap utxos wallet conf , submitTx = submitTx' network } From 326adeae195b75bd13778c3b98d09d93b1370ec5 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 13:44:45 +0200 Subject: [PATCH 13/50] update unsafe collateral estimation logic --- .../src/SubmitAPI/Internal/Balancing.hs | 8 ++--- .../src/SubmitAPI/Internal/Transaction.hs | 5 +-- submit-api/src/SubmitAPI/Service.hs | 35 ++++++++++++++++--- 3 files changed, 38 insertions(+), 10 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 120d5e2f..114034cf 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -24,18 +24,18 @@ makeTransactionBodyBalanceUnsafe => TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Integer + -> Integer -> Either TxBodyErrorAutoBalance (BalancedTxBody era) -makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue = do +makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue colAmount = do let era' = cardanoEra retColSup <- maybeToEitherOr (totalAndReturnCollateralSupportedInEra era') TxBodyErrorMissingParamMinUTxO -- incorrect error let fee = 300000 - reqAmt = 1300000 - totalCollateral = TxTotalCollateral retColSup (Lovelace reqAmt) + totalCollateral = TxTotalCollateral retColSup (Lovelace colAmount) (retColl, reqCol) = ( TxReturnCollateral retColSup - (TxOut changeaddr (lovelaceToTxOutValue (Lovelace reqAmt)) TxOutDatumNone ReferenceScriptNone) + (TxOut changeaddr (lovelaceToTxOutValue (Lovelace colAmount)) TxOutDatumNone ReferenceScriptNone) , totalCollateral ) explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ diff --git a/submit-api/src/SubmitAPI/Internal/Transaction.hs b/submit-api/src/SubmitAPI/Internal/Transaction.hs index d6172299..68c624e8 100644 --- a/submit-api/src/SubmitAPI/Internal/Transaction.hs +++ b/submit-api/src/SubmitAPI/Internal/Transaction.hs @@ -69,14 +69,15 @@ buildBalancedTxUnsafe -> Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> Integer + -> Integer -> f (BalancedTxBody BabbageEra) -buildBalancedTxUnsafe SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} changeValue = do +buildBalancedTxUnsafe SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} changeValue colAmount = do txBody <- buildTxBodyContent pparams network refScriptsMap collateral txc changeAddr <- absorbError $ case txCandidateChangePolicy of Just (Sdk.ReturnTo addr) -> Interop.toCardanoAddressInEra network addr _ -> Interop.toCardanoAddressInEra network $ Sdk.getAddress defaultChangeAddr absorbBalancingError $ - Balancing.makeTransactionBodyBalanceUnsafe txBody changeAddr changeValue + Balancing.makeTransactionBodyBalanceUnsafe txBody changeAddr changeValue colAmount where absorbBalancingError (Left e) = throwM $ BalancingError $ T.pack $ displayError e absorbBalancingError (Right a) = pure a diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 9f7ef588..84024461 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -20,6 +20,11 @@ import NetworkAPI.Types import WalletAPI.Utxos import WalletAPI.Vault import Cardano.Crypto.DSIGN.SchnorrSecp256k1 +import Cardano.Api (Lovelace(Lovelace)) +import Plutus.V1.Ledger.Value (assetClass) +import Plutus.V1.Ledger.Api (adaSymbol) +import Plutus.V1.Ledger.Api (adaToken) +import Ledger.Value (assetClassValueOf) data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace @@ -55,7 +60,7 @@ estimateTxFee' -> f C.Lovelace estimateTxFee' CardanoNetwork{..} network refScriptsMap collateral txc = do SystemEnv{pparams} <- getSystemEnv - Internal.estimateTxFee pparams network refScriptsMap collateral txc + Internal.estimateTxFee pparams network refScriptsMap collateral txc finalizeTx' :: MonadThrow f @@ -93,10 +98,10 @@ finalizeTxUnsafe' -> Integer -> f (C.Tx C.BabbageEra) finalizeTxUnsafe' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do - sysenv <- getSystemEnv - collaterals <- selectCollaterals utxos sysenv refScriptsMap network conf txc + sysenv <- getSystemEnv + (collaterals, colAmount) <- selectCollateralsUnsafe utxos sysenv conf txc - (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue + (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue colAmount let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) signatories = allInputs >>= getPkh @@ -149,3 +154,25 @@ selectCollaterals WalletOutputs{selectUtxosStrict} SystemEnv{..} refScriptsMap n ([], _) -> pure mempty (_, Cover) -> collectCollaterals mempty _ -> throwM CollateralNotAllowed + +selectCollateralsUnsafe + :: MonadThrow f + => WalletOutputs f + -> SystemEnv + -> TxAssemblyConfig + -> Sdk.TxCandidate + -> f (Set.Set Sdk.FullCollateralTxIn, Integer) +selectCollateralsUnsafe WalletOutputs{selectUtxosStrict} SystemEnv{..} TxAssemblyConfig{..} Sdk.TxCandidate{..} = do + let + collectCollaterals = do + utxos <- selectUtxosStrict (P.toValue (P.Lovelace 1300000)) >>= maybe (throwM FailedToSatisfyCollateral) pure + let + collaterals = Set.fromList $ Set.elems utxos <&> Sdk.FullCollateralTxIn + adaAC = assetClass adaSymbol adaToken + origValue = foldl (\acc Sdk.FullTxOut{..} -> acc + assetClassValueOf fullTxOutValue adaAC) 0 utxos + + pure (collaterals, origValue) + + case collateralPolicy of + Cover -> collectCollaterals + _ -> pure (mempty, 0) From a849d6c6a871c679d9ee7c0d3e7fac4517bc25df Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 14:10:47 +0200 Subject: [PATCH 14/50] add debug --- submit-api/src/SubmitAPI/Service.hs | 16 ++++++++++------ submit-api/submit-api.cabal | 1 + 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 84024461..1bae1673 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -25,6 +25,7 @@ import Plutus.V1.Ledger.Value (assetClass) import Plutus.V1.Ledger.Api (adaSymbol) import Plutus.V1.Ledger.Api (adaToken) import Ledger.Value (assetClassValueOf) +import System.Logging.Hlog data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace @@ -35,17 +36,18 @@ data Transactions f era = Transactions mkTransactions :: (MonadThrow f, MonadIO f) - => CardanoNetwork f C.BabbageEra + => Logging f + -> CardanoNetwork f C.BabbageEra -> C.NetworkId -> Map P.Script C.TxIn -> WalletOutputs f -> Vault f -> TxAssemblyConfig -> Transactions f C.BabbageEra -mkTransactions network networkId refScriptsMap utxos wallet conf = Transactions +mkTransactions logging network networkId refScriptsMap utxos wallet conf = Transactions { estimateTxFee = estimateTxFee' network networkId refScriptsMap , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf - , finalizeTxUnsafe = finalizeTxUnsafe' network networkId refScriptsMap utxos wallet conf + , finalizeTxUnsafe = finalizeTxUnsafe' logging network networkId refScriptsMap utxos wallet conf , submitTx = submitTx' network } @@ -88,7 +90,8 @@ finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAsse finalizeTxUnsafe' :: MonadThrow f - => CardanoNetwork f C.BabbageEra + => Logging f + -> CardanoNetwork f C.BabbageEra -> C.NetworkId -> Map P.Script C.TxIn -> WalletOutputs f @@ -97,10 +100,11 @@ finalizeTxUnsafe' -> Sdk.TxCandidate -> Integer -> f (C.Tx C.BabbageEra) -finalizeTxUnsafe' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do +finalizeTxUnsafe' Logging{..} CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do sysenv <- getSystemEnv (collaterals, colAmount) <- selectCollateralsUnsafe utxos sysenv conf txc - + infoM $ "Collaterals: " ++ show collaterals + infoM $ "Collaterals amount: " ++ show colAmount (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue colAmount let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index f959a94c..5c1d878e 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -96,6 +96,7 @@ library aeson, servant, singletons, + hlog, either, aeson-gadt-th, plutus-script-utils, From aca710203c1bfb0ee6dd63a45bf8f9c73082c1a3 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 14:43:13 +0200 Subject: [PATCH 15/50] change return collateral --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 114034cf..2c0e3aed 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -33,9 +33,7 @@ makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue colAmount fee = 300000 totalCollateral = TxTotalCollateral retColSup (Lovelace colAmount) (retColl, reqCol) = - ( TxReturnCollateral - retColSup - (TxOut changeaddr (lovelaceToTxOutValue (Lovelace colAmount)) TxOutDatumNone ReferenceScriptNone) + ( TxReturnCollateralNone , totalCollateral ) explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ From 936a286df32dbefa099c5002064984a5afc21467 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 14:56:12 +0200 Subject: [PATCH 16/50] remove debug --- submit-api/src/SubmitAPI/Service.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 1bae1673..e2807e40 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -103,8 +103,6 @@ finalizeTxUnsafe' finalizeTxUnsafe' Logging{..} CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do sysenv <- getSystemEnv (collaterals, colAmount) <- selectCollateralsUnsafe utxos sysenv conf txc - infoM $ "Collaterals: " ++ show collaterals - infoM $ "Collaterals amount: " ++ show colAmount (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue colAmount let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) From e91e1b25010109e9a42b50f8b74370f89a6bb0a1 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 15:10:35 +0200 Subject: [PATCH 17/50] increase fee --- dex-core/src/ErgoDex/Amm/PoolActions.hs | 6 +++--- submit-api/src/SubmitAPI/Internal/Balancing.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 3ffa72d1..1567ffc3 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -138,7 +138,7 @@ runSwapUnsafe' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFee when (poolReservesX pool * 2 <= lqBound pool) (Left $ InsufficientPoolLqForSwap (poolId pool)) let - fee = 300000 + fee = 320000 exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen rewardAddr = pubKeyHashAddress (PaymentPubKeyHash swapRewardPkh) swapRewardSPkh rewardOut = @@ -189,7 +189,7 @@ runDepositUnsafe' runDepositUnsafe' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do when (depositPoolId /= poolId) (Left $ PoolMismatch depositPoolId poolId) let - fee = 300000 + fee = 320000 inputs = mkOrderInputs P.Deposit pv dv (PoolIn poolOut) (OrderIn depositOut) (inX, inY) = @@ -265,7 +265,7 @@ runRedeemUnsafe' runRedeemUnsafe' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do when (redeemPoolId /= poolId) (Left $ PoolMismatch redeemPoolId poolId) let - fee = 300000 + fee = 320000 inputs = mkOrderInputs P.Redeem pv rv (PoolIn poolOut) (OrderIn redeemOut) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 2c0e3aed..a8ef588a 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -30,7 +30,7 @@ makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue colAmount let era' = cardanoEra retColSup <- maybeToEitherOr (totalAndReturnCollateralSupportedInEra era') TxBodyErrorMissingParamMinUTxO -- incorrect error let - fee = 300000 + fee = 320000 totalCollateral = TxTotalCollateral retColSup (Lovelace colAmount) (retColl, reqCol) = ( TxReturnCollateralNone From d7a8acc2a4d34e6e4fb8706fa3583d73e738ebf1 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 15:46:12 +0200 Subject: [PATCH 18/50] debug for exUnits --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index a8ef588a..4740452f 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -16,7 +16,7 @@ import Cardano.Api import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, ReferenceScript (..), fromShelleyLovelace) import qualified Cardano.Ledger.Coin as Ledger import Debug.Trace -import Control.FromSum +import Control.FromSum ( fromMaybe, maybeToEitherOr ) makeTransactionBodyBalanceUnsafe :: forall era. @@ -93,6 +93,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams failures exUnitsMap' + traceM $ "exUnitsMap:" ++ show exUnitsMap + txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ From 2c5a6ed9c70efb81d9ce0377f37a1f5752905553 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 16:05:48 +0200 Subject: [PATCH 19/50] add substituteExecutionUnitsUnsafe --- .../src/SubmitAPI/Internal/Balancing.hs | 20 +++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 4740452f..102ba95a 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -18,6 +18,9 @@ import qualified Cardano.Ledger.Coin as Ledger import Debug.Trace import Control.FromSum ( fromMaybe, maybeToEitherOr ) +-- exUnitsMap:fromList [(ScriptWitnessIndexTxIn 0,Right (ExecutionUnits {executionSteps = 130605779, executionMemory = 298198})), +-- (ScriptWitnessIndexTxIn 1,Right (ExecutionUnits {executionSteps = 133934187, executionMemory = 302164}))] + makeTransactionBodyBalanceUnsafe :: forall era. IsShelleyBasedEra era @@ -38,14 +41,27 @@ makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue colAmount ) explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ txFeesExplicitInEra era' - txBody0 <- first TxBodyError $ makeTransactionBody txbodycontent + txBody0 <- substituteExecutionUnitsUnsafe txbodycontent + txBodyFinal <- first TxBodyError $ makeTransactionBody txBody0 { txOuts = txOuts txbodycontent , txFee = TxFeeExplicit explicitTxFees $ Lovelace fee , txReturnCollateral = retColl , txTotalCollateral = reqCol } - return (BalancedTxBody txBody0 (TxOut changeaddr (lovelaceToTxOutValue (Lovelace changeValue)) TxOutDatumNone ReferenceScriptNone) (Lovelace fee)) + return (BalancedTxBody txBodyFinal (TxOut changeaddr (lovelaceToTxOutValue (Lovelace changeValue)) TxOutDatumNone ReferenceScriptNone) (Lovelace fee)) +substituteExecutionUnitsUnsafe :: TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) +substituteExecutionUnitsUnsafe = + mapTxScriptWitnesses f + where + f :: ScriptWitnessIndex + -> ScriptWitness witctx era + -> Either TxBodyErrorAutoBalance (ScriptWitness witctx era) + f _ wit@SimpleScriptWitness{} = Right wit + f _ (PlutusScriptWitness langInEra version script datum redeemer _) = + Right $ PlutusScriptWitness langInEra version script + datum redeemer (ExecutionUnits 134500000 304000) + makeTransactionBodyAutoBalance :: forall era mode. IsShelleyBasedEra era From fef1fda26bccf831397ba47dce791e098da1cb52 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 16:24:22 +0200 Subject: [PATCH 20/50] update exunits --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 102ba95a..9cf2d550 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -60,8 +60,8 @@ substituteExecutionUnitsUnsafe = f _ wit@SimpleScriptWitness{} = Right wit f _ (PlutusScriptWitness langInEra version script datum redeemer _) = Right $ PlutusScriptWitness langInEra version script - datum redeemer (ExecutionUnits 134500000 304000) - + datum redeemer (ExecutionUnits 140000000 320000) + makeTransactionBodyAutoBalance :: forall era mode. IsShelleyBasedEra era From 512633642386e1f6c1cfed6a592a85890e335dff Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 21:25:46 +0200 Subject: [PATCH 21/50] add UnsafeEvalConfig --- dex-core/dex-core.cabal | 1 + dex-core/src/ErgoDex/Amm/PoolActions.hs | 32 +++++++++++-------- submit-api/src/SubmitAPI/Config.hs | 9 ++++++ .../src/SubmitAPI/Internal/Balancing.hs | 8 +++-- .../src/SubmitAPI/Internal/Transaction.hs | 8 +++-- submit-api/src/SubmitAPI/Service.hs | 14 ++++---- 6 files changed, 46 insertions(+), 26 deletions(-) diff --git a/dex-core/dex-core.cabal b/dex-core/dex-core.cabal index 945a5d5d..26948ca6 100644 --- a/dex-core/dex-core.cabal +++ b/dex-core/dex-core.cabal @@ -111,6 +111,7 @@ library either, extra, transformers, + submit-api, cardano-api, text, serialise, diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 1567ffc3..70d6c81a 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -30,6 +30,7 @@ import ErgoDex.Contracts.Types import CardanoTx.Models import System.Logging.Hlog (Logging (Logging)) import Plutus.V1.Ledger.Value (Value) +import SubmitAPI.Config data OrderExecErr = PriceTooHigh @@ -89,14 +90,14 @@ data PoolActions = PoolActions , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) } -mkPoolActions :: PaymentPubKeyHash -> AmmValidators V1 -> PoolActions -mkPoolActions executorPkh AmmValidators{..} = PoolActions +mkPoolActions :: UnsafeEvalConfig -> PaymentPubKeyHash -> AmmValidators V1 -> PoolActions +mkPoolActions evalCfg executorPkh AmmValidators{..} = PoolActions { runSwapWithDebug = runSwapWithDebug' executorPkh poolV swapV , runDepositWithDebug = runDepositWithDebug' executorPkh poolV depositV , runRedeemWithDebug = runRedeemWithDebug' executorPkh poolV redeemV - , runSwap = runSwapUnsafe' executorPkh poolV swapV - , runDeposit = runDepositUnsafe' executorPkh poolV depositV - , runRedeem = runRedeemUnsafe' executorPkh poolV redeemV + , runSwap = runSwapUnsafe' evalCfg executorPkh poolV swapV + , runDeposit = runDepositUnsafe' evalCfg executorPkh poolV depositV + , runRedeem = runRedeemUnsafe' evalCfg executorPkh poolV redeemV } newtype PoolIn = PoolIn FullTxOut @@ -120,14 +121,15 @@ mkOrderInputs action (PoolValidator pv) ov' (PoolIn poolOut) (OrderIn orderOut) in Set.fromList [poolIn, orderIn] runSwapUnsafe' - :: PaymentPubKeyHash + :: UnsafeEvalConfig + -> PaymentPubKeyHash -> PoolValidator V1 -> SwapValidator V1 -> [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) -runSwapUnsafe' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFeePerToken{..}, ..}) (poolOut, pool) = do +runSwapUnsafe' UnsafeEvalConfig{..} 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) @@ -138,7 +140,7 @@ runSwapUnsafe' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFee when (poolReservesX pool * 2 <= lqBound pool) (Left $ InsufficientPoolLqForSwap (poolId pool)) let - fee = 320000 + fee = unsafeTxFee exFee = assetAmountRawValue quoteOutput * exFeePerTokenNum `div` exFeePerTokenDen rewardAddr = pubKeyHashAddress (PaymentPubKeyHash swapRewardPkh) swapRewardSPkh rewardOut = @@ -179,17 +181,18 @@ runSwapUnsafe' executorPkh pv sv refInputs (OnChain swapOut Swap{swapExFee=ExFee Right (txCandidate, pp, exFee - fee) runDepositUnsafe' - :: PaymentPubKeyHash + :: UnsafeEvalConfig + -> PaymentPubKeyHash -> PoolValidator V1 -> DepositValidator V1 -> [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) -runDepositUnsafe' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do +runDepositUnsafe' UnsafeEvalConfig{..} executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) (poolOut, pool@Pool{..}) = do when (depositPoolId /= poolId) (Left $ PoolMismatch depositPoolId poolId) let - fee = 320000 + fee = unsafeTxFee inputs = mkOrderInputs P.Deposit pv dv (PoolIn poolOut) (OrderIn depositOut) (inX, inY) = @@ -255,17 +258,18 @@ runDepositUnsafe' executorPkh pv dv refInputs (OnChain depositOut Deposit{..}) ( Right (txCandidate, pp, unAmount exFee - fee) runRedeemUnsafe' - :: PaymentPubKeyHash + :: UnsafeEvalConfig + -> PaymentPubKeyHash -> PoolValidator V1 -> RedeemValidator V1 -> [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) -runRedeemUnsafe' executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do +runRedeemUnsafe' UnsafeEvalConfig{..} executorPkh pv rv refInputs (OnChain redeemOut Redeem{..}) (poolOut, pool@Pool{..}) = do when (redeemPoolId /= poolId) (Left $ PoolMismatch redeemPoolId poolId) let - fee = 320000 + fee = unsafeTxFee inputs = mkOrderInputs P.Redeem pv rv (PoolIn poolOut) (OrderIn redeemOut) diff --git a/submit-api/src/SubmitAPI/Config.hs b/submit-api/src/SubmitAPI/Config.hs index f4af1f11..9b69a70b 100644 --- a/submit-api/src/SubmitAPI/Config.hs +++ b/submit-api/src/SubmitAPI/Config.hs @@ -3,6 +3,7 @@ module SubmitAPI.Config , CollateralPolicy(..) , TxAssemblyConfig(..) , DefaultChangeAddress(..) + , UnsafeEvalConfig(..) , unwrapChangeAddress ) where @@ -37,6 +38,14 @@ data TxAssemblyConfig = TxAssemblyConfig instance D.FromDhall TxAssemblyConfig +data UnsafeEvalConfig = UnsafeEvalConfig + { unsafeTxFee :: Integer + , exUnits :: Integer + , exMem :: Integer + } deriving Generic + +instance D.FromDhall UnsafeEvalConfig + newtype DefaultChangeAddress = DefaultChangeAddress { getChangeAddr :: ChangeAddress } unwrapChangeAddress :: DefaultChangeAddress -> Address diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 9cf2d550..57aa6383 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -17,6 +17,7 @@ import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, ReferenceScript (. import qualified Cardano.Ledger.Coin as Ledger import Debug.Trace import Control.FromSum ( fromMaybe, maybeToEitherOr ) +import SubmitAPI.Config (UnsafeEvalConfig (..)) -- exUnitsMap:fromList [(ScriptWitnessIndexTxIn 0,Right (ExecutionUnits {executionSteps = 130605779, executionMemory = 298198})), -- (ScriptWitnessIndexTxIn 1,Right (ExecutionUnits {executionSteps = 133934187, executionMemory = 302164}))] @@ -24,16 +25,17 @@ import Control.FromSum ( fromMaybe, maybeToEitherOr ) makeTransactionBodyBalanceUnsafe :: forall era. IsShelleyBasedEra era - => TxBodyContent BuildTx era + => UnsafeEvalConfig + -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Integer -> Integer -> Either TxBodyErrorAutoBalance (BalancedTxBody era) -makeTransactionBodyBalanceUnsafe txbodycontent changeaddr changeValue colAmount = do +makeTransactionBodyBalanceUnsafe cfg@UnsafeEvalConfig{..} txbodycontent changeaddr changeValue colAmount = do let era' = cardanoEra retColSup <- maybeToEitherOr (totalAndReturnCollateralSupportedInEra era') TxBodyErrorMissingParamMinUTxO -- incorrect error let - fee = 320000 + fee = unsafeTxFee totalCollateral = TxTotalCollateral retColSup (Lovelace colAmount) (retColl, reqCol) = ( TxReturnCollateralNone diff --git a/submit-api/src/SubmitAPI/Internal/Transaction.hs b/submit-api/src/SubmitAPI/Internal/Transaction.hs index 68c624e8..7b9d1430 100644 --- a/submit-api/src/SubmitAPI/Internal/Transaction.hs +++ b/submit-api/src/SubmitAPI/Internal/Transaction.hs @@ -28,6 +28,7 @@ import qualified CardanoTx.Models as Sdk import qualified SubmitAPI.Internal.Balancing as Balancing import CardanoTx.ToPlutus import NetworkAPI.Types +import SubmitAPI.Config signTx :: TxBody BabbageEra @@ -62,7 +63,8 @@ buildBalancedTx SystemEnv{..} refScriptsMap network defaultChangeAddr collateral buildBalancedTxUnsafe :: (MonadThrow f) - => SystemEnv + => UnsafeEvalConfig + -> SystemEnv -> Map P.Script C.TxIn -> NetworkId -> Sdk.ChangeAddress @@ -71,13 +73,13 @@ buildBalancedTxUnsafe -> Integer -> Integer -> f (BalancedTxBody BabbageEra) -buildBalancedTxUnsafe SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} changeValue colAmount = do +buildBalancedTxUnsafe cfg SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} changeValue colAmount = do txBody <- buildTxBodyContent pparams network refScriptsMap collateral txc changeAddr <- absorbError $ case txCandidateChangePolicy of Just (Sdk.ReturnTo addr) -> Interop.toCardanoAddressInEra network addr _ -> Interop.toCardanoAddressInEra network $ Sdk.getAddress defaultChangeAddr absorbBalancingError $ - Balancing.makeTransactionBodyBalanceUnsafe txBody changeAddr changeValue colAmount + Balancing.makeTransactionBodyBalanceUnsafe cfg txBody changeAddr changeValue colAmount where absorbBalancingError (Left e) = throwM $ BalancingError $ T.pack $ displayError e absorbBalancingError (Right a) = pure a diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index e2807e40..d2dee5a7 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -36,7 +36,8 @@ data Transactions f era = Transactions mkTransactions :: (MonadThrow f, MonadIO f) - => Logging f + => UnsafeEvalConfig + -> Logging f -> CardanoNetwork f C.BabbageEra -> C.NetworkId -> Map P.Script C.TxIn @@ -44,10 +45,10 @@ mkTransactions -> Vault f -> TxAssemblyConfig -> Transactions f C.BabbageEra -mkTransactions logging network networkId refScriptsMap utxos wallet conf = Transactions +mkTransactions cfg logging network networkId refScriptsMap utxos wallet conf = Transactions { estimateTxFee = estimateTxFee' network networkId refScriptsMap , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf - , finalizeTxUnsafe = finalizeTxUnsafe' logging network networkId refScriptsMap utxos wallet conf + , finalizeTxUnsafe = finalizeTxUnsafe' cfg logging network networkId refScriptsMap utxos wallet conf , submitTx = submitTx' network } @@ -90,7 +91,8 @@ finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAsse finalizeTxUnsafe' :: MonadThrow f - => Logging f + => UnsafeEvalConfig + -> Logging f -> CardanoNetwork f C.BabbageEra -> C.NetworkId -> Map P.Script C.TxIn @@ -100,10 +102,10 @@ finalizeTxUnsafe' -> Sdk.TxCandidate -> Integer -> f (C.Tx C.BabbageEra) -finalizeTxUnsafe' Logging{..} CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do +finalizeTxUnsafe' cfg Logging{..} CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} changeValue = do sysenv <- getSystemEnv (collaterals, colAmount) <- selectCollateralsUnsafe utxos sysenv conf txc - (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue colAmount + (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTxUnsafe cfg sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc changeValue colAmount let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) signatories = allInputs >>= getPkh From d67876ee27b62a95cba1b018539d09555fe2b55c Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sun, 30 Jul 2023 23:13:49 +0200 Subject: [PATCH 22/50] add cfg to substituteExecutionUnitsUnsafe --- submit-api/src/SubmitAPI/Config.hs | 5 +++-- submit-api/src/SubmitAPI/Internal/Balancing.hs | 8 ++++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/submit-api/src/SubmitAPI/Config.hs b/submit-api/src/SubmitAPI/Config.hs index 9b69a70b..2b62cd1c 100644 --- a/submit-api/src/SubmitAPI/Config.hs +++ b/submit-api/src/SubmitAPI/Config.hs @@ -15,6 +15,7 @@ import Ledger (Address) import qualified Cardano.Api as C import qualified Ledger.Tx.CardanoAPI as Interop import CardanoTx.Models (ChangeAddress(..)) +import Dhall (Natural) data FeePolicy = Strict -- Require existing TX inputs to cover fee entirely @@ -40,8 +41,8 @@ instance D.FromDhall TxAssemblyConfig data UnsafeEvalConfig = UnsafeEvalConfig { unsafeTxFee :: Integer - , exUnits :: Integer - , exMem :: Integer + , exUnits :: Natural + , exMem :: Natural } deriving Generic instance D.FromDhall UnsafeEvalConfig diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 57aa6383..672e46d0 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -43,7 +43,7 @@ makeTransactionBodyBalanceUnsafe cfg@UnsafeEvalConfig{..} txbodycontent changead ) explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ txFeesExplicitInEra era' - txBody0 <- substituteExecutionUnitsUnsafe txbodycontent + txBody0 <- substituteExecutionUnitsUnsafe cfg txbodycontent txBodyFinal <- first TxBodyError $ makeTransactionBody txBody0 { txOuts = txOuts txbodycontent , txFee = TxFeeExplicit explicitTxFees $ Lovelace fee @@ -52,8 +52,8 @@ makeTransactionBodyBalanceUnsafe cfg@UnsafeEvalConfig{..} txbodycontent changead } return (BalancedTxBody txBodyFinal (TxOut changeaddr (lovelaceToTxOutValue (Lovelace changeValue)) TxOutDatumNone ReferenceScriptNone) (Lovelace fee)) -substituteExecutionUnitsUnsafe :: TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) -substituteExecutionUnitsUnsafe = +substituteExecutionUnitsUnsafe :: UnsafeEvalConfig -> TxBodyContent BuildTx era -> Either TxBodyErrorAutoBalance (TxBodyContent BuildTx era) +substituteExecutionUnitsUnsafe UnsafeEvalConfig{..} = mapTxScriptWitnesses f where f :: ScriptWitnessIndex @@ -62,7 +62,7 @@ substituteExecutionUnitsUnsafe = f _ wit@SimpleScriptWitness{} = Right wit f _ (PlutusScriptWitness langInEra version script datum redeemer _) = Right $ PlutusScriptWitness langInEra version script - datum redeemer (ExecutionUnits 140000000 320000) + datum redeemer (ExecutionUnits exUnits exMem) makeTransactionBodyAutoBalance :: forall era mode. From fcadfb499f2a479e71245e837b6d4132db8f1e03 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 31 Jul 2023 00:14:36 +0200 Subject: [PATCH 23/50] fix reward addr --- dex-core/src/ErgoDex/Amm/PoolActions.hs | 6 +++--- submit-api/test/Main.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index 70d6c81a..d7a3739d 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -161,7 +161,7 @@ runSwapUnsafe' UnsafeEvalConfig{..} executorPkh pv sv refInputs (OnChain swapOut executorRewardOut = TxOutCandidate - { txOutCandidateAddress = rewardAddr + { txOutCandidateAddress = pubKeyHashAddress executorPkh Nothing , txOutCandidateValue = Ada.lovelaceValueOf (exFee - fee) , txOutCandidateDatum = EmptyDatum , txOutCandidateRefScript = Nothing @@ -238,7 +238,7 @@ runDepositUnsafe' UnsafeEvalConfig{..} executorPkh pv dv refInputs (OnChain depo executorRewardOut = TxOutCandidate - { txOutCandidateAddress = rewardAddr + { txOutCandidateAddress = pubKeyHashAddress executorPkh Nothing , txOutCandidateValue = Ada.lovelaceValueOf (unAmount exFee - fee) , txOutCandidateDatum = EmptyDatum , txOutCandidateRefScript = Nothing @@ -300,7 +300,7 @@ runRedeemUnsafe' UnsafeEvalConfig{..} executorPkh pv rv refInputs (OnChain redee executorRewardOut = TxOutCandidate - { txOutCandidateAddress = rewardAddr + { txOutCandidateAddress = pubKeyHashAddress executorPkh Nothing , txOutCandidateValue = Ada.lovelaceValueOf (exFee - fee) , txOutCandidateDatum = EmptyDatum , txOutCandidateRefScript = Nothing diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 86002f3a..1d775423 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -129,7 +129,7 @@ dq = "\"" main :: IO () main = do - txFile + test123 txFile :: IO () txFile = do From f5687fd9375126acf0883ae922d489c838570f43 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Tue, 29 Aug 2023 11:13:39 +0200 Subject: [PATCH 24/50] add v2 --- cabal.project | 2 +- dex-core/src/ErgoDex/ScriptsValidators.hs | 2 +- dex-core/src/ErgoDex/Validators.hs | 4 +- nix/pkgs/haskell/haskell.nix | 2 +- submit-api/submit-api.cabal | 1 + submit-api/test/Main.hs | 282 ++++++++++++++++------ 6 files changed, 218 insertions(+), 75 deletions(-) diff --git a/cabal.project b/cabal.project index e49a7e07..57b0c1a2 100644 --- a/cabal.project +++ b/cabal.project @@ -313,7 +313,7 @@ source-repository-package source-repository-package type: git location: https://github.com/ergolabs/cardano-dex-contracts - tag: b4330de32e2d8be821a8a4fd3fd2d24508c280d7 + tag: c25c8ab7daf52871d29efd00d3dac236cc9d6a36 subdir: cardano-dex-contracts-offchain diff --git a/dex-core/src/ErgoDex/ScriptsValidators.hs b/dex-core/src/ErgoDex/ScriptsValidators.hs index f56e012a..b18565a2 100644 --- a/dex-core/src/ErgoDex/ScriptsValidators.hs +++ b/dex-core/src/ErgoDex/ScriptsValidators.hs @@ -14,7 +14,7 @@ import qualified Plutus.V2.Ledger.Api as PV2 import ErgoDex.Amm.PoolActions ( AmmValidators (..) ) import ErgoDex.Validators - ( V1, PoolValidator (..), OrderValidator (..) ) + ( Version(..), PoolValidator (..), OrderValidator (..) ) import System.Logging.Hlog import CardanoTx.Models (FullTxOut(..)) import ErgoDex.State (Confirmed(Confirmed), OnChain (OnChain)) diff --git a/dex-core/src/ErgoDex/Validators.hs b/dex-core/src/ErgoDex/Validators.hs index 8635c827..cdb913c5 100644 --- a/dex-core/src/ErgoDex/Validators.hs +++ b/dex-core/src/ErgoDex/Validators.hs @@ -1,5 +1,5 @@ module ErgoDex.Validators - ( V1 + ( Version(..) , PoolValidator(..) , OrderValidator(..) , orderValidator @@ -23,7 +23,7 @@ import ErgoDex.PValidators newtype PoolValidator ver = PoolValidator PV2.Validator -data V1 +data Version = V1 | V2 data SwapK data DepositK diff --git a/nix/pkgs/haskell/haskell.nix b/nix/pkgs/haskell/haskell.nix index 101c8f6b..a8a0228c 100644 --- a/nix/pkgs/haskell/haskell.nix +++ b/nix/pkgs/haskell/haskell.nix @@ -43,7 +43,7 @@ let "https://github.com/input-output-hk/cardano-ledger"."c7c63dabdb215ebdaed8b63274965966f2bf408f" = "zTQbMOGPD1Oodv6VUsfF6NUiXkbN8SWI98W3Atv4wbI="; "https://github.com/input-output-hk/plutus-apps"."593ffafa59dd30ad28cfaf144c526c66328595d2" = "CIuI/Nz7O67ljOHDg7UBbXgWuIE7VPRdPX4VK0/DI3A="; "https://github.com/input-output-hk/hedgehog-extras"."714ee03a5a786a05fc57ac5d2f1c2edce4660d85" = "6KQFEzb9g2a0soVvwLKESEbA+a8ygpROcMr6bkatROE="; - "https://github.com/ergolabs/cardano-dex-contracts"."b4330de32e2d8be821a8a4fd3fd2d24508c280d7" = "exJoEIagnfPYqW3Tj96/Q/A/dR9c2jW5KPSahXfazfg="; + "https://github.com/ergolabs/cardano-dex-contracts"."c25c8ab7daf52871d29efd00d3dac236cc9d6a36" = "/A2kO/ABqElTxeIcyA2SIqwX9StNLTe5GyE80h+Rf8w="; "https://github.com/ergolabs/hlog"."19dfa3a6e696a3f63fc3539cd6b7a3fc4d999853" = "Lvmj1oLuXmktrboXh/BrXqLPf8FxSCXIf99GnBXu0Bk="; "https://github.com/daleiz/rocksdb-haskell"."109af08f95b40f458d4933e3725ecb3e59337c39" = "1i1ya491fapa0g96527krarv0w0iybizqcz518741iw06hhpikiy"; }; diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index 5c1d878e..1d3a0730 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -154,6 +154,7 @@ test-suite submit-api-tests , plutus-script-utils , plutus-ledger , containers + , either , random-strings , plutus-core , cardano-ledger-shelley diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 1d775423..c2b147f0 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -8,7 +8,12 @@ import qualified Data.Text.Encoding as E import Test.Tasty import Test.Tasty.HUnit +import qualified Data.Aeson as Aeson import PlutusTx.Builtins.Internal hiding (fst) +import qualified Cardano.Api as Api +import qualified Data.Either.Combinators as EC +import qualified Ledger as P +import qualified PlutusTx.Builtins.Internal as BI import PlutusTx import ErgoDex.Contracts.Pool import qualified Data.ByteString as BS @@ -18,7 +23,7 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Short as SBS import qualified Data.ByteString.Lazy as LBS import Codec.Serialise (serialise, deserialise) -import Data.Aeson as Json ( encode ) +import Data.Aeson as Json ( encode, decode, FromJSON (parseJSON) ) import qualified Data.Text.Encoding as E import qualified Data.ByteString.Base16 as Hex import Plutus.Script.Utils.V2.Scripts @@ -29,7 +34,7 @@ import Plutus.V1.Ledger.Api import ErgoDex.PValidators import Cardano.CLI.Shelley.Run.Transaction import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema), InAnyCardanoEra (InAnyCardanoEra), EraInMode (BabbageEraInCardanoMode), IsShelleyBasedEra) -import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode)) +import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode), toPlutusData) import qualified Plutus.V1.Ledger.Scripts as Plutus import qualified Cardano.Api as C import qualified Plutus.Script.Utils.V2.Address as PV2 @@ -54,6 +59,8 @@ import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) +import Explorer.Models (FullTxOut) +import ErgoDex.Contracts.Proxy.Swap (SwapConfig(SwapConfig)) data TokenInfo = TokenInfo @@ -92,6 +99,9 @@ workDir = "/home/bromel/test-mainnet-pools/" mintingPolicyNamePostfix :: String mintingPolicyNamePostfix = "_mintingPolicy" +mintingPolicyNFTNamePostfix = "_mintingPolicyNFT" +mintingPolicyLQNamePostfix = "_mintingPolicyLQ" + stakingScriptNamePostfix :: String stakingScriptNamePostfix = "_stakingScript" @@ -113,6 +123,24 @@ uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ upl plutusPolicyPath :: PoolInfo -> String plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension +uplcPolicyLqPath :: PoolInfo -> String +uplcPolicyLqPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ uplcExtension + +uplcPolicyNftPath :: PoolInfo -> String +uplcPolicyNftPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ uplcExtension + +plutusLqPolicyPath :: PoolInfo -> String +plutusLqPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ plutusExtension + +plutusNftPolicyPath :: PoolInfo -> String +plutusNftPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ plutusExtension + +plutusLqPolicyPathWithDir :: PoolInfo -> String -> String +plutusLqPolicyPathWithDir PoolInfo{..} dir = dir ++ name ++ mintingPolicyLQNamePostfix ++ plutusExtension + +plutusNftPolicyPathwithDir :: PoolInfo -> String -> String +plutusNftPolicyPathwithDir PoolInfo{..} dir = dir ++ name ++ mintingPolicyNFTNamePostfix ++ plutusExtension + uplcStakingScriptPath :: String -> String uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension @@ -125,6 +153,17 @@ poolDatumPath PoolInfo{..} = workDir ++ name ++ poolDatumPostfix ++ jsonExtensio poolMainnetServerDatumPath :: String -> PoolInfo -> String poolMainnetServerDatumPath mainnetWorkDir PoolInfo{..} = mainnetWorkDir ++ name ++ poolDatumPostfix ++ jsonExtension +adanftPostfix = "5F4144415F4E4654" +adalqPostfix = "5F4144415F4C51" + +wallet1PubKeyHash = "a78c50e7b7c4ebff6881701d3ae48198dcdbab1b731d77139e33f3d0" +wallet2PubKeyHash = "6b4f0eace88f760261eddd8495bf4b8e3ae9743e7b65674deb90885d" +wallet3PubKeyHash = "add49ae8756c1f76e69ef87f598a8e6ad1eff47deab073cc979ad132" + +mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] + +signaturesThreshold = 2 + dq = "\"" main :: IO () @@ -242,79 +281,53 @@ test3 = do } print depositAddress - + print $ show $ toBuiltinData ctx -- print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" pure () test123 = do - let - trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") - vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO + readDatumJson + -- let + -- trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") + -- vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO - mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes + -- mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes - pkh <- getPaymentKeyHash vault + -- pkh <- getPaymentKeyHash vault - let - address = (mkPCred pkh) + -- let + -- address = (mkPCred pkh) - print address + -- print address -- defaultMain tests let - wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" - wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" - - mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] + poolsInfo = + [ ("COPI", "b6a7467ea1deb012808ef4e87b5ff371e85f7142d7b356a40d9b42a0", "436f726e75636f70696173205b76696120436861696e506f72742e696f5d" , 0, 100000000, 869565217) + , ("IBTC", "f66d78b4a3cb3d37afa0ec36461e51ecbde00f26c8f0a68f94b69880", "69425443", 10000000000, 100000000, 928) + , ("MELD", "a2944573e99d2ed3055b808eaa264f0bf119e01fc6b18863067c63e4", "4d454c44", 10000000000, 100000000, 2049180328) + , ("NTX", "edfd7a1d77bcb8b884c474bdc92a16002d1fb720e454fa6e99344479", "4e5458", 10000000000, 100000000, 699300699) + , ("AGIX", "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535", "41474958", 10000000000, 100000000, 14727540501) + , ("cBTC", "4190b2941d9be04acc69c39739bd5acc66d60ccab480d8e20bc87e37", "63425443", 10000000000, 150000000, 163681) + ] + lqQty = 9223372036854775807 - signaturesThreshold = 2 + -- pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] - lqQty = 9223372036854775807 + -- bytes <- BS.readFile "/home/bromel/projects/cardano-dex-contracts/cardano-dex-contracts-offchain/Contracts/pool.uplc" + -- let + -- shortBS = SBS.toShort bytes + -- scr :: PlutusScript PlutusScriptV2 + -- scr = PlutusScriptSerialised shortBS + -- print $ scriptHash (deserialise (LBS.fromStrict bytes)) - rabbitPool = PoolInfo - { name = "rabbitPool" - , tokenX = adaTokenInfo - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6e6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6c71" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 15000000 - , initialYQty = 15000000 - , allowStaking = True - } - goldfishPool = PoolInfo - { name = "goldfishPool" - , tokenX = adaTokenInfo - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6e6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6c71" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 15000000 - , initialYQty = 15000000000 - , allowStaking = True - } - rabbitFoldfishPool = PoolInfo - { name = "rabbitGoldfishPool" - , tokenX = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6E6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6C71" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 1000000 - , initialYQty = 1000000 - , allowStaking = False - } - pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] + --writeFileTextEnvelope "/home/bromel/projects/cardano-dex-sdk-haskell/submit-api/pool.plutus" Nothing scr -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus + pools <- createFirstPoolInfo `traverse` poolsInfo + -- convertUplcMintingPolicy `traverse` pools -- Step 1.5 (optional) @@ -329,31 +342,37 @@ test123 = do -- Also we cannot retrive original min utxo value for inline datums. So, set it manually -- More Also, we cannot determine change. So, set it manually too - -- let - -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" - -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" - -- -- on mainnet machine - -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" + let + poolAddressWithStaking = "addr1x94ec3t25egvhqy2n265xfhq882jxhkknurfe9ny4rl9k6dj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrst84slu" + poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" + -- on mainnet machine + origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" + + bootstrapAddressString = "" + bootstrapAddressVKeyPath = "" - -- bootstrapAddressString = "" - -- bootstrapAddressVKeyPath = "" + minUtxoValueForPool = 3223960 - -- minUtxoValueForPool = 3223960 + res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools - -- res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools + folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res - -- folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res + -- mintRes <- mintingCLICreationOutput pools -- putStr folded + -- putStr mintRes + + --putStr folded + -- end --print $ readShellyAddress "addr1v8g2jvkr55vsqlteuu5x0052lgj3ak0ev5vs74dyu0fgahg92dth0" -- print $ readShellyAddress "addr1qxupdk69sdemdx80far0tsvrydz7zj67ydzxxujmv9srj3tcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsy8ugdz" - print $ readShellyAddress "addr1qxy8aeh2e77hgtrevn4p459m7qsqswfnkxck26g2cuanh2ncgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqf8en8" - print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" + --print $ readShellyAddress "addr1x94ec3t25egvhqy2n265xfhq882jxhkknurfe9ny4rl9k6dj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrst84slu" + --print $ readShellyAddress "addr1x8nz307k3sr60gu0e47cmajssy4fmld7u493a4xztjrll0aj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrswgxsta" -- let testData = "hgCYrxoAAyNhGQMsAQEZA+gZAjsAARkD6BlecQQBGQPoGCAaAAHKdhko6wQZWdgYZBlZ2BhkGVnYGGQZWdgYZBlZ2BhkGVnYGGQYZBhkGVnYGGQZTFEYIBoAAqz6GCAZtVEEGgADYxUZAf8AARoAAVw1GCAaAAeXdRk29AQCGgAC/5QaAAbqeBjcAAEBGQPoGW/2BAIaAAO9CBoAA07FGD4BGgAQLg8ZMSoBGgADLoAZAaUBGgAC2ngZA+gZzwYBGgABOjQYIBmo8RggGQPoGCAaAAE6rAEZ4UMEGQPoChoAAwIZGJwBGgADAhkYnAEaAAMgfBkB2QEaAAMwABkB/wEZzPMYIBn9QBggGf/VGCAZWB4YIBlAsxggGgABKt8YIBoAAv+UGgAG6ngY3AABARoAAQ+SGS2nAAEZ6rsYIBoAAv+UGgAG6ngY3AABARoAAv+UGgAG6ngY3AABARoAEbIsGgAF/d4AAhoADFBOGXcSBBoAHWr2GgABQlsEGgAEDGYABAAaAAFPqxggGgADI2EZAywBARmg3hggGgADPXYYIBl59BggGX+4GCAZqV0YIBl99xggGZWqGCAaAiOszAoaA3T2kxlKHwoaAlFehBmAswqCGgCYloAbAAAAAhhxGgBZBHFZBG4BAAAyMjIyMjIyMjIyMjIyMjIyMjIyMjIyIiUzMBUyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMlMzAvM3DpABABCZGRkZGSmZgaGbh1MzA0M3Dm60wNTA2ARSAAFIAAUgAkgABUzAlM3DmYFQBhgagPJABCpmBKZuvMDUAYwNQChUzAlM3DmZgZkRKZmBiACIAQmYAZm4AAJIAIwOQAUgAAFUgBBUzAlUzMDQzcOAEACKURUzMDQzcQAEACJmZmYEYB5gagOAAgBABgCiZmZmBGAeYGoDoAQAIAgAombiVMzA0M3EgBAAiAEIAJmBUAeYGoDYmZEZkYGxEpmYGYAIpQFTMwOTN15gdAAgBilETACMDsAE3UgAgBG6wwNTIwNzA3MDcwNzA3ABMDYBY3XGBqAyZmZmBGAQYGgDYAQAhutMDQBk3WmBoYGoC5mZmYEQA5gZgNgBABm60wMwGDdaYGZgaALGYE4BJgZAMmYEwBBgYgMmbgUg/v//////////ATMCUAcwMAFhYwMgAjApABN1RgWmBcAubqzIwLTAuMC8AEwLDAtABMC0AEzAmN1pgVADgFG6syMCowKzAsABMCkwKgATAqABMwIzdaYE4AoA5mRGRkZKZmBUZGRkpmYFpm4dIAIAITIyMlMzAwM3DpAAABClATN15unAEN04AJgZgBGBUACbqgBxMjIyUzMDAzcOkAEAEKUBM3Xm6cAQ3TgAmBmAEYFQAJuqAHMDAAIwJwATdUACIAQsZGRkZGSmZgXGbh0gAAAhMjIyMlMzAyM3DpAAABCZGRkZKZmBsZuHSACACFhM3SpAAAAmByAEYGAAJuqABMDMAEWMDUAIwLAATdUACYF4AImbpUgAgKTAxACMCgAE3VAAmBWYFhgWgAmBUYFgApurMjIyUzMCszcOkAEAELCpmYFZm483XGBYACAMJgWGBaYFwA4sYFwARgSgAm6oAEyMCkwKwATAoMCoAM3XGBMAUYEwBJmBCbrTAlABAEMCUAEwJAATAkAON1hgQgBG6wwIAAjAgMCAAEwIDAeAIMB4AEwHQATAcABMBsAEwGgATAZABMBkAQwGAARSYWIiIiM3EmbgzNwRm4EAQAMAIAEzANAGAFIiIiMjNwZm4JTMwFzIyUzAKM3Hm64wGjAbACN1xgNGA2ACJm483XGA0AEbrjAaABMBsAswGgBhM3AmbgQAQAwAhABAEAFMwDABgBSIzMBEAIAEAMUoGbpUgADMAE3UgBGYAJupACAIV0CRAQAiMjMwBAAzdcYBwAJuuMA4wDwATAPABIiMzMAQAJIAAjMzAFACSAAdabqwAQAyMAI3UgAkREZgFESmZgDgAiAKKmZgGmbrzAJMA4AEAYTAEMBEwDgARMAIwDwAQAVVz6XrgVXOkSmZgCmbiAAkgABYTMAMAIAEwASIlMzAFM3DgBJAACYAwAImYAZm4EAJIAIwBwASMjACIzACACABIwAiMwAgAgAVc0roVdERgBG6oAFVc8Gf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP/YeZ8AAAAB/9h5n9h5n5/YeZ/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/2Hmf2Hmf2HqfWBwHXgnrD6ieHcNGkbPFan9DfmCsXqZ7M48uF24g/9h6gP+iQKFAGgC2NddYHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej+hRFNORUsZJxDYe5/YeZ/YeZ9YHEonRlESo5Rk5t1e5HDFUuuzy0KSXV7AQBSWeQhMU05FS19BREFfTkZU/9h5n0BA/9h5n1gcJ5yQnzSOUz2lgIiY+H+aFLssPfu6zM1jHZJ6P0RTTkVL/9h5n1gce93ywn8lfu7vPoknWLR54JyJpzZCSZeX8ql/PEtTTkVLX0FEQV9MUf8aABbjYFgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJdh5n1gceEb2uwf1soJYheRQJnnmmbTmCgxGCaRrw1RUzf8A///YeoD///+f2Hmf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A/9h5n9h5n9h6n1gcB14J6w+onh3DRpGzxWp/Q35grF6mezOPLhduIP/YeoD/okChQBoAtjXXWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2Huf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP//2HqA///YeZ/YeZ/YeZ9YIPyemf0SoToTdyXaYeV6QQ42dH1RO5ZZk9ksMsZ9+SWa/wD/2Hmf2Hmf2HmfWBym4Zc+U6+AxHPK+yiCNYZPZiQNMF2c6d+ZISXq/9h5n9h5n9h5n1gcP3DvBZXbx1DWV12BSvjaDNtT53ja5Ilehe8jnv////+hQKFAGgC7K2TYeYDYeZ9YHAdeCesPqJ4dw0aRs8Vqf0N+YKxepnszjy4XbiD/////n9h5n9h5n9h5n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7P/YeZ/YeZ/YeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/////okChQBoAn5uEWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2HmA2HqA//+hQKFAGgAWmlOhQKFAAICg2Hmf2Hmf2HmA2HqA/9h5n9h7gNh6gP//n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7FgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJf+h2Hqf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A///YeZ8AAAAB/6DYeZ9YIDMW4vM4hWi8LBR8kV4+xSzqkd2A8PJeMjwpxJhhd4zB///Yep/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/////gggA" -- plutusData = Data.from testData @@ -377,6 +396,54 @@ test123 = do --- Pool creation stuff --- +getNftPolicy :: PoolInfo -> IO String +getNftPolicy pi = do + nftMintingPolicy <- getPoolNftMintingPolicy pi + let nftHash = scriptHash (unMintingPolicyScript nftMintingPolicy) + pure (show nftHash) + +getLqPolicy :: PoolInfo -> IO String +getLqPolicy pi = do + lqMintingPolicy <- getPoolLQMintingPolicy pi + let lqHash = scriptHash (unMintingPolicyScript lqMintingPolicy) + pure (show lqHash) + +-- poolName, policy token minAda deployAda +createFirstPoolInfo :: (String, String, String, Integer, Integer, Integer) -> IO PoolInfo +createFirstPoolInfo (poolName, policy, base16, minAda, deployAda, token) = do + let + tokenBase16 = if (base16 == "436f726e75636f70696173205b76696120436861696e506f72742e696f5d") then "436F726E75636F70696173" else base16 + testPi = PoolInfo { + name = poolName + , tokenX = adaTokenInfo + , tokenY = TokenInfo policy base16 + , tokenNft = TokenInfo "85157c33ec50d85e920f341a808062c827b91595c1ffe7ee2b162be25b13cbee" (tokenBase16 ++ adanftPostfix) + , tokenLP = TokenInfo "85157c33ec50d85e920f341a808062c827b91595c1ffe7ee2b162be25b13cbee" (tokenBase16 ++ adalqPostfix) + , lqBound = minAda + , authKeys = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] + , threshold = signaturesThreshold + , initialXQty = deployAda + , initialYQty = token + , allowStaking = True + } + + + nft <- getNftPolicy testPi + lq <- getLqPolicy testPi + pure $ PoolInfo { + name = poolName + , tokenX = adaTokenInfo + , tokenY = TokenInfo policy base16 + , tokenNft = TokenInfo nft (tokenBase16 ++ adanftPostfix) + , tokenLP = TokenInfo lq (tokenBase16 ++ adalqPostfix) + , lqBound = minAda + , authKeys = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] + , threshold = signaturesThreshold + , initialXQty = deployAda + , initialYQty = token + , allowStaking = True + } + -- return cardano-cli string for pool and lp charge for user poolCLICreationOutput :: PoolInfo -> String -> String -> Integer -> String -> String poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxoValue origDatumWorkDir = @@ -398,6 +465,39 @@ poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxo in toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum +mintingCLICreationOutput :: [PoolInfo] -> IO String +mintingCLICreationOutput piList = do + mintInfo <- poolInfoMint `traverse` piList + mintScripts <- poolInfoScriptMint `traverse` piList + let foldedMintInfo = (foldl (\acc nextInfo -> acc ++ "+" ++ nextInfo) "" mintInfo) ++ " \\" + -- tokenYValue = "+" ++ dq ++ show initialYQty ++ " " ++ show tokenY ++ dq + -- tokenNftValue = "+" ++ dq ++ "1 " ++ show tokenNft ++ dq + + -- charge = floor . sqrt . fromIntegral $ (initialXQty * initialYQty) + + -- tokenLpValue = "+" ++ dq ++ show (lqInitQty - charge) ++ " " ++ show tokenLP ++ dq + + -- address = if allowStaking then poolAddressWithStaking else poolAddress + + -- toCardanoCliPoolValue = "--tx-out " ++ address ++ "+" ++ adaValue ++ tokenXValue ++ tokenYValue ++ tokenNftValue ++ tokenLpValue ++ " \\" + + -- toCardanoCliDatum = "--tx-out-inline-datum-file " ++ poolMainnetServerDatumPath origDatumWorkDir pi ++ " \\" + + pure $ foldedMintInfo ++ ['\n'] ++ (concat mintScripts) -- toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum + +poolInfoMint :: PoolInfo -> IO String +poolInfoMint PoolInfo{..} = do + pure $ dq ++ "1 " ++ show tokenNft ++ dq ++ "+" ++ dq ++ "9223372036854775807 " ++ show tokenLP ++ dq + +poolInfoScriptMint :: PoolInfo -> IO String +poolInfoScriptMint pi@PoolInfo{..} = do + let + nftMint = "--mint-script-file " ++ plutusNftPolicyPathwithDir pi "/root/plutus-scripts-for-mainnet/test-pools/datums/" ++ " \\" ++ ['\n'] + nftRedeemer = "--mint-redeemer-file /root/plutus-scripts-for-mainnet/datums/unit.json" ++ " \\" ++ ['\n'] + lqMint = "--mint-script-file " ++ plutusLqPolicyPathWithDir pi "/root/plutus-scripts-for-mainnet/test-pools/datums/" ++ " \\" ++ ['\n'] + lqRedeemer = "--mint-redeemer-file /root/plutus-scripts-for-mainnet/datums/unit.json" ++ " \\" ++ ['\n'] + pure $ nftMint ++ nftRedeemer ++ lqMint ++ lqRedeemer + --- Datum creation stuff --- createDatumJson :: PoolInfo -> IO () @@ -418,7 +518,7 @@ createDatumJson pi@PoolInfo{..} = do pure [mpCS] else pure [] - let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound + let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 997 policies lqBound writeDatumToJson pi poolConfig pure () @@ -431,6 +531,17 @@ writeDatumToJson pi poolDatum = . toData $ poolDatum ) +readDatumJson :: IO () +readDatumJson = do + let + a = "{\"a\":123}" + test = decode a :: Maybe FullTxOut + rawDataM = decode "{\"fields\": [ { \"fields\": [ { \"bytes\": \"\" }, { \"bytes\": \"\" } ], \"constructor\": 0 }, { \"fields\": [ { \"bytes\": \"b34b3ea80060ace9427bda98690a73d33840e27aaa8d6edb7f0c757a\" }, { \"bytes\": \"634e455441\" } ], \"constructor\": 0 }, { \"fields\": [ { \"bytes\": \"bca5f2951474244a220f7336f5789fbf9cfbb7fe62bf225a9c99fcae\" }, { \"bytes\": \"636e6574615f6164615f6e6674\" } ], \"constructor\": 0 }, { \"int\": 997 }, { \"int\": 31250 }, { \"int\": 1 }, { \"bytes\": \"1f8cd6fa960aae53525e68d5e84880f1c889e827344730d8e830f172\" }, { \"fields\": [ { \"bytes\": \"9db7e35cb62c4bf25bd2140230bf9aff73a6319bbee02d727a871b22\" } ], \"constructor\": 0 }, { \"int\": 1000000 }, { \"int\": 48 } ], \"constructor\": 0 }" :: Maybe Aeson.Value + jsonDataM = rawDataM >>= (EC.rightToMaybe . Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema) + data' = (fmap (fromBuiltinData . BI.dataToBuiltinData . toPlutusData) jsonDataM) :: Maybe (Maybe SwapConfig) + print test + print data' + pure () --- Minting policies stuff --- convertUplcMintingPolicy :: PoolInfo -> IO () @@ -444,6 +555,19 @@ convertUplcMintingPolicy pi@PoolInfo{..} = scr = PlutusScriptSerialised shortBS writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr pure () + lqBytes <- BS.readFile (uplcPolicyLqPath pi) + let + shortLqBS = SBS.toShort lqBytes + lqscr :: PlutusScript PlutusScriptV2 + lqscr = PlutusScriptSerialised shortLqBS + writeFileTextEnvelope (plutusLqPolicyPath pi) Nothing lqscr + nftBytes <- BS.readFile (uplcPolicyNftPath pi) + let + nftshortBS = SBS.toShort nftBytes + nftscr :: PlutusScript PlutusScriptV2 + nftscr = PlutusScriptSerialised nftshortBS + writeFileTextEnvelope (plutusNftPolicyPath pi) Nothing nftscr + pure () else pure () getPoolMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy @@ -453,6 +577,24 @@ getPoolMintingPolicy pi = do script = deserialise (LBS.fromStrict bytes) pure (PlutusV2.MintingPolicy script) +getPoolLQMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolLQMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyLqPath pi) + let + script = deserialise (LBS.fromStrict bytes) + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash (PlutusV2.MintingPolicy script) + mpCS = CurrencySymbol mpPolicyHash + pure (PlutusV2.MintingPolicy script) + +getPoolNftMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolNftMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyNftPath pi) + let + script = deserialise (LBS.fromStrict bytes) + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash (PlutusV2.MintingPolicy script) + mpCS = CurrencySymbol mpPolicyHash + pure (PlutusV2.MintingPolicy script) + --- Staking scripts stuff --- convertUplcStakingScript :: String -> IO () From 6369658a22a9a899ee25f4d68480da2e81c6479a Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Tue, 29 Aug 2023 11:16:28 +0200 Subject: [PATCH 25/50] cleanup --- dex-core/src/ErgoDex/Validators.hs | 1 + submit-api/test/Main.hs | 282 +++++++---------------------- 2 files changed, 71 insertions(+), 212 deletions(-) diff --git a/dex-core/src/ErgoDex/Validators.hs b/dex-core/src/ErgoDex/Validators.hs index cdb913c5..3df54afc 100644 --- a/dex-core/src/ErgoDex/Validators.hs +++ b/dex-core/src/ErgoDex/Validators.hs @@ -20,6 +20,7 @@ import RIO ((<&>)) import qualified Plutus.V2.Ledger.Api as PV2 import ErgoDex.PValidators + ( depositValidator, poolValidator, redeemValidator, swapValidator ) newtype PoolValidator ver = PoolValidator PV2.Validator diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index c2b147f0..1d775423 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -8,12 +8,7 @@ import qualified Data.Text.Encoding as E import Test.Tasty import Test.Tasty.HUnit -import qualified Data.Aeson as Aeson import PlutusTx.Builtins.Internal hiding (fst) -import qualified Cardano.Api as Api -import qualified Data.Either.Combinators as EC -import qualified Ledger as P -import qualified PlutusTx.Builtins.Internal as BI import PlutusTx import ErgoDex.Contracts.Pool import qualified Data.ByteString as BS @@ -23,7 +18,7 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Short as SBS import qualified Data.ByteString.Lazy as LBS import Codec.Serialise (serialise, deserialise) -import Data.Aeson as Json ( encode, decode, FromJSON (parseJSON) ) +import Data.Aeson as Json ( encode ) import qualified Data.Text.Encoding as E import qualified Data.ByteString.Base16 as Hex import Plutus.Script.Utils.V2.Scripts @@ -34,7 +29,7 @@ import Plutus.V1.Ledger.Api import ErgoDex.PValidators import Cardano.CLI.Shelley.Run.Transaction import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema), InAnyCardanoEra (InAnyCardanoEra), EraInMode (BabbageEraInCardanoMode), IsShelleyBasedEra) -import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode), toPlutusData) +import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode)) import qualified Plutus.V1.Ledger.Scripts as Plutus import qualified Cardano.Api as C import qualified Plutus.Script.Utils.V2.Address as PV2 @@ -59,8 +54,6 @@ import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) -import Explorer.Models (FullTxOut) -import ErgoDex.Contracts.Proxy.Swap (SwapConfig(SwapConfig)) data TokenInfo = TokenInfo @@ -99,9 +92,6 @@ workDir = "/home/bromel/test-mainnet-pools/" mintingPolicyNamePostfix :: String mintingPolicyNamePostfix = "_mintingPolicy" -mintingPolicyNFTNamePostfix = "_mintingPolicyNFT" -mintingPolicyLQNamePostfix = "_mintingPolicyLQ" - stakingScriptNamePostfix :: String stakingScriptNamePostfix = "_stakingScript" @@ -123,24 +113,6 @@ uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ upl plutusPolicyPath :: PoolInfo -> String plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension -uplcPolicyLqPath :: PoolInfo -> String -uplcPolicyLqPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ uplcExtension - -uplcPolicyNftPath :: PoolInfo -> String -uplcPolicyNftPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ uplcExtension - -plutusLqPolicyPath :: PoolInfo -> String -plutusLqPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ plutusExtension - -plutusNftPolicyPath :: PoolInfo -> String -plutusNftPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ plutusExtension - -plutusLqPolicyPathWithDir :: PoolInfo -> String -> String -plutusLqPolicyPathWithDir PoolInfo{..} dir = dir ++ name ++ mintingPolicyLQNamePostfix ++ plutusExtension - -plutusNftPolicyPathwithDir :: PoolInfo -> String -> String -plutusNftPolicyPathwithDir PoolInfo{..} dir = dir ++ name ++ mintingPolicyNFTNamePostfix ++ plutusExtension - uplcStakingScriptPath :: String -> String uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension @@ -153,17 +125,6 @@ poolDatumPath PoolInfo{..} = workDir ++ name ++ poolDatumPostfix ++ jsonExtensio poolMainnetServerDatumPath :: String -> PoolInfo -> String poolMainnetServerDatumPath mainnetWorkDir PoolInfo{..} = mainnetWorkDir ++ name ++ poolDatumPostfix ++ jsonExtension -adanftPostfix = "5F4144415F4E4654" -adalqPostfix = "5F4144415F4C51" - -wallet1PubKeyHash = "a78c50e7b7c4ebff6881701d3ae48198dcdbab1b731d77139e33f3d0" -wallet2PubKeyHash = "6b4f0eace88f760261eddd8495bf4b8e3ae9743e7b65674deb90885d" -wallet3PubKeyHash = "add49ae8756c1f76e69ef87f598a8e6ad1eff47deab073cc979ad132" - -mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] - -signaturesThreshold = 2 - dq = "\"" main :: IO () @@ -281,52 +242,78 @@ test3 = do } print depositAddress - + print $ show $ toBuiltinData ctx -- print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" pure () test123 = do - readDatumJson - -- let - -- trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") - -- vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO + let + trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") + vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO - -- mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes + mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes - -- pkh <- getPaymentKeyHash vault + pkh <- getPaymentKeyHash vault - -- let - -- address = (mkPCred pkh) + let + address = (mkPCred pkh) - -- print address + print address -- defaultMain tests let - poolsInfo = - [ ("COPI", "b6a7467ea1deb012808ef4e87b5ff371e85f7142d7b356a40d9b42a0", "436f726e75636f70696173205b76696120436861696e506f72742e696f5d" , 0, 100000000, 869565217) - , ("IBTC", "f66d78b4a3cb3d37afa0ec36461e51ecbde00f26c8f0a68f94b69880", "69425443", 10000000000, 100000000, 928) - , ("MELD", "a2944573e99d2ed3055b808eaa264f0bf119e01fc6b18863067c63e4", "4d454c44", 10000000000, 100000000, 2049180328) - , ("NTX", "edfd7a1d77bcb8b884c474bdc92a16002d1fb720e454fa6e99344479", "4e5458", 10000000000, 100000000, 699300699) - , ("AGIX", "f43a62fdc3965df486de8a0d32fe800963589c41b38946602a0dc535", "41474958", 10000000000, 100000000, 14727540501) - , ("cBTC", "4190b2941d9be04acc69c39739bd5acc66d60ccab480d8e20bc87e37", "63425443", 10000000000, 150000000, 163681) - ] - lqQty = 9223372036854775807 + wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" + wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" - -- pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] + mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] - -- bytes <- BS.readFile "/home/bromel/projects/cardano-dex-contracts/cardano-dex-contracts-offchain/Contracts/pool.uplc" - -- let - -- shortBS = SBS.toShort bytes - -- scr :: PlutusScript PlutusScriptV2 - -- scr = PlutusScriptSerialised shortBS - -- print $ scriptHash (deserialise (LBS.fromStrict bytes)) + signaturesThreshold = 2 - --writeFileTextEnvelope "/home/bromel/projects/cardano-dex-sdk-haskell/submit-api/pool.plutus" Nothing scr + lqQty = 9223372036854775807 - -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus + rabbitPool = PoolInfo + { name = "rabbitPool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6e6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6c71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 15000000 + , initialYQty = 15000000 + , allowStaking = True + } + goldfishPool = PoolInfo + { name = "goldfishPool" + , tokenX = adaTokenInfo + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6e6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6c71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 15000000 + , initialYQty = 15000000000 + , allowStaking = True + } + rabbitFoldfishPool = PoolInfo + { name = "rabbitGoldfishPool" + , tokenX = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" + , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" + , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6E6674" + , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6C71" + , lqBound = 5000000 + , authKeys = [] + , threshold = signaturesThreshold + , initialXQty = 1000000 + , initialYQty = 1000000 + , allowStaking = False + } + pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] - pools <- createFirstPoolInfo `traverse` poolsInfo + -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus -- convertUplcMintingPolicy `traverse` pools @@ -342,37 +329,31 @@ test123 = do -- Also we cannot retrive original min utxo value for inline datums. So, set it manually -- More Also, we cannot determine change. So, set it manually too - let - poolAddressWithStaking = "addr1x94ec3t25egvhqy2n265xfhq882jxhkknurfe9ny4rl9k6dj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrst84slu" - poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" - -- on mainnet machine - origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" - - bootstrapAddressString = "" - bootstrapAddressVKeyPath = "" + -- let + -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" + -- -- on mainnet machine + -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" - minUtxoValueForPool = 3223960 + -- bootstrapAddressString = "" + -- bootstrapAddressVKeyPath = "" - res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools + -- minUtxoValueForPool = 3223960 - folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res + -- res = (\pi -> poolCLICreationOutput pi poolAddressWithStaking poolAddress minUtxoValueForPool origDatumWorkDir) `fmap` pools - -- mintRes <- mintingCLICreationOutput pools + -- folded = foldr (\acc nextPool -> acc ++ "\n" ++ nextPool) "" res -- putStr folded - -- putStr mintRes - - --putStr folded - -- end --print $ readShellyAddress "addr1v8g2jvkr55vsqlteuu5x0052lgj3ak0ev5vs74dyu0fgahg92dth0" -- print $ readShellyAddress "addr1qxupdk69sdemdx80far0tsvrydz7zj67ydzxxujmv9srj3tcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsy8ugdz" - --print $ readShellyAddress "addr1x94ec3t25egvhqy2n265xfhq882jxhkknurfe9ny4rl9k6dj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrst84slu" - --print $ readShellyAddress "addr1x8nz307k3sr60gu0e47cmajssy4fmld7u493a4xztjrll0aj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrswgxsta" + print $ readShellyAddress "addr1qxy8aeh2e77hgtrevn4p459m7qsqswfnkxck26g2cuanh2ncgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqf8en8" + print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" -- let testData = "hgCYrxoAAyNhGQMsAQEZA+gZAjsAARkD6BlecQQBGQPoGCAaAAHKdhko6wQZWdgYZBlZ2BhkGVnYGGQZWdgYZBlZ2BhkGVnYGGQYZBhkGVnYGGQZTFEYIBoAAqz6GCAZtVEEGgADYxUZAf8AARoAAVw1GCAaAAeXdRk29AQCGgAC/5QaAAbqeBjcAAEBGQPoGW/2BAIaAAO9CBoAA07FGD4BGgAQLg8ZMSoBGgADLoAZAaUBGgAC2ngZA+gZzwYBGgABOjQYIBmo8RggGQPoGCAaAAE6rAEZ4UMEGQPoChoAAwIZGJwBGgADAhkYnAEaAAMgfBkB2QEaAAMwABkB/wEZzPMYIBn9QBggGf/VGCAZWB4YIBlAsxggGgABKt8YIBoAAv+UGgAG6ngY3AABARoAAQ+SGS2nAAEZ6rsYIBoAAv+UGgAG6ngY3AABARoAAv+UGgAG6ngY3AABARoAEbIsGgAF/d4AAhoADFBOGXcSBBoAHWr2GgABQlsEGgAEDGYABAAaAAFPqxggGgADI2EZAywBARmg3hggGgADPXYYIBl59BggGX+4GCAZqV0YIBl99xggGZWqGCAaAiOszAoaA3T2kxlKHwoaAlFehBmAswqCGgCYloAbAAAAAhhxGgBZBHFZBG4BAAAyMjIyMjIyMjIyMjIyMjIyMjIyMjIyIiUzMBUyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMlMzAvM3DpABABCZGRkZGSmZgaGbh1MzA0M3Dm60wNTA2ARSAAFIAAUgAkgABUzAlM3DmYFQBhgagPJABCpmBKZuvMDUAYwNQChUzAlM3DmZgZkRKZmBiACIAQmYAZm4AAJIAIwOQAUgAAFUgBBUzAlUzMDQzcOAEACKURUzMDQzcQAEACJmZmYEYB5gagOAAgBABgCiZmZmBGAeYGoDoAQAIAgAombiVMzA0M3EgBAAiAEIAJmBUAeYGoDYmZEZkYGxEpmYGYAIpQFTMwOTN15gdAAgBilETACMDsAE3UgAgBG6wwNTIwNzA3MDcwNzA3ABMDYBY3XGBqAyZmZmBGAQYGgDYAQAhutMDQBk3WmBoYGoC5mZmYEQA5gZgNgBABm60wMwGDdaYGZgaALGYE4BJgZAMmYEwBBgYgMmbgUg/v//////////ATMCUAcwMAFhYwMgAjApABN1RgWmBcAubqzIwLTAuMC8AEwLDAtABMC0AEzAmN1pgVADgFG6syMCowKzAsABMCkwKgATAqABMwIzdaYE4AoA5mRGRkZKZmBUZGRkpmYFpm4dIAIAITIyMlMzAwM3DpAAABClATN15unAEN04AJgZgBGBUACbqgBxMjIyUzMDAzcOkAEAEKUBM3Xm6cAQ3TgAmBmAEYFQAJuqAHMDAAIwJwATdUACIAQsZGRkZGSmZgXGbh0gAAAhMjIyMlMzAyM3DpAAABCZGRkZKZmBsZuHSACACFhM3SpAAAAmByAEYGAAJuqABMDMAEWMDUAIwLAATdUACYF4AImbpUgAgKTAxACMCgAE3VAAmBWYFhgWgAmBUYFgApurMjIyUzMCszcOkAEAELCpmYFZm483XGBYACAMJgWGBaYFwA4sYFwARgSgAm6oAEyMCkwKwATAoMCoAM3XGBMAUYEwBJmBCbrTAlABAEMCUAEwJAATAkAON1hgQgBG6wwIAAjAgMCAAEwIDAeAIMB4AEwHQATAcABMBsAEwGgATAZABMBkAQwGAARSYWIiIiM3EmbgzNwRm4EAQAMAIAEzANAGAFIiIiMjNwZm4JTMwFzIyUzAKM3Hm64wGjAbACN1xgNGA2ACJm483XGA0AEbrjAaABMBsAswGgBhM3AmbgQAQAwAhABAEAFMwDABgBSIzMBEAIAEAMUoGbpUgADMAE3UgBGYAJupACAIV0CRAQAiMjMwBAAzdcYBwAJuuMA4wDwATAPABIiMzMAQAJIAAjMzAFACSAAdabqwAQAyMAI3UgAkREZgFESmZgDgAiAKKmZgGmbrzAJMA4AEAYTAEMBEwDgARMAIwDwAQAVVz6XrgVXOkSmZgCmbiAAkgABYTMAMAIAEwASIlMzAFM3DgBJAACYAwAImYAZm4EAJIAIwBwASMjACIzACACABIwAiMwAgAgAVc0roVdERgBG6oAFVc8Gf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP/YeZ8AAAAB/9h5n9h5n5/YeZ/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/2Hmf2Hmf2HqfWBwHXgnrD6ieHcNGkbPFan9DfmCsXqZ7M48uF24g/9h6gP+iQKFAGgC2NddYHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej+hRFNORUsZJxDYe5/YeZ/YeZ9YHEonRlESo5Rk5t1e5HDFUuuzy0KSXV7AQBSWeQhMU05FS19BREFfTkZU/9h5n0BA/9h5n1gcJ5yQnzSOUz2lgIiY+H+aFLssPfu6zM1jHZJ6P0RTTkVL/9h5n1gce93ywn8lfu7vPoknWLR54JyJpzZCSZeX8ql/PEtTTkVLX0FEQV9MUf8aABbjYFgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJdh5n1gceEb2uwf1soJYheRQJnnmmbTmCgxGCaRrw1RUzf8A///YeoD///+f2Hmf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A/9h5n9h5n9h6n1gcB14J6w+onh3DRpGzxWp/Q35grF6mezOPLhduIP/YeoD/okChQBoAtjXXWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2Huf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP//2HqA///YeZ/YeZ/YeZ9YIPyemf0SoToTdyXaYeV6QQ42dH1RO5ZZk9ksMsZ9+SWa/wD/2Hmf2Hmf2HmfWBym4Zc+U6+AxHPK+yiCNYZPZiQNMF2c6d+ZISXq/9h5n9h5n9h5n1gcP3DvBZXbx1DWV12BSvjaDNtT53ja5Ilehe8jnv////+hQKFAGgC7K2TYeYDYeZ9YHAdeCesPqJ4dw0aRs8Vqf0N+YKxepnszjy4XbiD/////n9h5n9h5n9h5n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7P/YeZ/YeZ/YeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/////okChQBoAn5uEWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2HmA2HqA//+hQKFAGgAWmlOhQKFAAICg2Hmf2Hmf2HmA2HqA/9h5n9h7gNh6gP//n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7FgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJf+h2Hqf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A///YeZ8AAAAB/6DYeZ9YIDMW4vM4hWi8LBR8kV4+xSzqkd2A8PJeMjwpxJhhd4zB///Yep/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/////gggA" -- plutusData = Data.from testData @@ -396,54 +377,6 @@ test123 = do --- Pool creation stuff --- -getNftPolicy :: PoolInfo -> IO String -getNftPolicy pi = do - nftMintingPolicy <- getPoolNftMintingPolicy pi - let nftHash = scriptHash (unMintingPolicyScript nftMintingPolicy) - pure (show nftHash) - -getLqPolicy :: PoolInfo -> IO String -getLqPolicy pi = do - lqMintingPolicy <- getPoolLQMintingPolicy pi - let lqHash = scriptHash (unMintingPolicyScript lqMintingPolicy) - pure (show lqHash) - --- poolName, policy token minAda deployAda -createFirstPoolInfo :: (String, String, String, Integer, Integer, Integer) -> IO PoolInfo -createFirstPoolInfo (poolName, policy, base16, minAda, deployAda, token) = do - let - tokenBase16 = if (base16 == "436f726e75636f70696173205b76696120436861696e506f72742e696f5d") then "436F726E75636F70696173" else base16 - testPi = PoolInfo { - name = poolName - , tokenX = adaTokenInfo - , tokenY = TokenInfo policy base16 - , tokenNft = TokenInfo "85157c33ec50d85e920f341a808062c827b91595c1ffe7ee2b162be25b13cbee" (tokenBase16 ++ adanftPostfix) - , tokenLP = TokenInfo "85157c33ec50d85e920f341a808062c827b91595c1ffe7ee2b162be25b13cbee" (tokenBase16 ++ adalqPostfix) - , lqBound = minAda - , authKeys = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] - , threshold = signaturesThreshold - , initialXQty = deployAda - , initialYQty = token - , allowStaking = True - } - - - nft <- getNftPolicy testPi - lq <- getLqPolicy testPi - pure $ PoolInfo { - name = poolName - , tokenX = adaTokenInfo - , tokenY = TokenInfo policy base16 - , tokenNft = TokenInfo nft (tokenBase16 ++ adanftPostfix) - , tokenLP = TokenInfo lq (tokenBase16 ++ adalqPostfix) - , lqBound = minAda - , authKeys = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] - , threshold = signaturesThreshold - , initialXQty = deployAda - , initialYQty = token - , allowStaking = True - } - -- return cardano-cli string for pool and lp charge for user poolCLICreationOutput :: PoolInfo -> String -> String -> Integer -> String -> String poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxoValue origDatumWorkDir = @@ -465,39 +398,6 @@ poolCLICreationOutput pi@PoolInfo{..} poolAddressWithStaking poolAddress minUtxo in toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum -mintingCLICreationOutput :: [PoolInfo] -> IO String -mintingCLICreationOutput piList = do - mintInfo <- poolInfoMint `traverse` piList - mintScripts <- poolInfoScriptMint `traverse` piList - let foldedMintInfo = (foldl (\acc nextInfo -> acc ++ "+" ++ nextInfo) "" mintInfo) ++ " \\" - -- tokenYValue = "+" ++ dq ++ show initialYQty ++ " " ++ show tokenY ++ dq - -- tokenNftValue = "+" ++ dq ++ "1 " ++ show tokenNft ++ dq - - -- charge = floor . sqrt . fromIntegral $ (initialXQty * initialYQty) - - -- tokenLpValue = "+" ++ dq ++ show (lqInitQty - charge) ++ " " ++ show tokenLP ++ dq - - -- address = if allowStaking then poolAddressWithStaking else poolAddress - - -- toCardanoCliPoolValue = "--tx-out " ++ address ++ "+" ++ adaValue ++ tokenXValue ++ tokenYValue ++ tokenNftValue ++ tokenLpValue ++ " \\" - - -- toCardanoCliDatum = "--tx-out-inline-datum-file " ++ poolMainnetServerDatumPath origDatumWorkDir pi ++ " \\" - - pure $ foldedMintInfo ++ ['\n'] ++ (concat mintScripts) -- toCardanoCliPoolValue ++ ['\n'] ++ toCardanoCliDatum - -poolInfoMint :: PoolInfo -> IO String -poolInfoMint PoolInfo{..} = do - pure $ dq ++ "1 " ++ show tokenNft ++ dq ++ "+" ++ dq ++ "9223372036854775807 " ++ show tokenLP ++ dq - -poolInfoScriptMint :: PoolInfo -> IO String -poolInfoScriptMint pi@PoolInfo{..} = do - let - nftMint = "--mint-script-file " ++ plutusNftPolicyPathwithDir pi "/root/plutus-scripts-for-mainnet/test-pools/datums/" ++ " \\" ++ ['\n'] - nftRedeemer = "--mint-redeemer-file /root/plutus-scripts-for-mainnet/datums/unit.json" ++ " \\" ++ ['\n'] - lqMint = "--mint-script-file " ++ plutusLqPolicyPathWithDir pi "/root/plutus-scripts-for-mainnet/test-pools/datums/" ++ " \\" ++ ['\n'] - lqRedeemer = "--mint-redeemer-file /root/plutus-scripts-for-mainnet/datums/unit.json" ++ " \\" ++ ['\n'] - pure $ nftMint ++ nftRedeemer ++ lqMint ++ lqRedeemer - --- Datum creation stuff --- createDatumJson :: PoolInfo -> IO () @@ -518,7 +418,7 @@ createDatumJson pi@PoolInfo{..} = do pure [mpCS] else pure [] - let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 997 policies lqBound + let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound writeDatumToJson pi poolConfig pure () @@ -531,17 +431,6 @@ writeDatumToJson pi poolDatum = . toData $ poolDatum ) -readDatumJson :: IO () -readDatumJson = do - let - a = "{\"a\":123}" - test = decode a :: Maybe FullTxOut - rawDataM = decode "{\"fields\": [ { \"fields\": [ { \"bytes\": \"\" }, { \"bytes\": \"\" } ], \"constructor\": 0 }, { \"fields\": [ { \"bytes\": \"b34b3ea80060ace9427bda98690a73d33840e27aaa8d6edb7f0c757a\" }, { \"bytes\": \"634e455441\" } ], \"constructor\": 0 }, { \"fields\": [ { \"bytes\": \"bca5f2951474244a220f7336f5789fbf9cfbb7fe62bf225a9c99fcae\" }, { \"bytes\": \"636e6574615f6164615f6e6674\" } ], \"constructor\": 0 }, { \"int\": 997 }, { \"int\": 31250 }, { \"int\": 1 }, { \"bytes\": \"1f8cd6fa960aae53525e68d5e84880f1c889e827344730d8e830f172\" }, { \"fields\": [ { \"bytes\": \"9db7e35cb62c4bf25bd2140230bf9aff73a6319bbee02d727a871b22\" } ], \"constructor\": 0 }, { \"int\": 1000000 }, { \"int\": 48 } ], \"constructor\": 0 }" :: Maybe Aeson.Value - jsonDataM = rawDataM >>= (EC.rightToMaybe . Api.scriptDataFromJson Api.ScriptDataJsonDetailedSchema) - data' = (fmap (fromBuiltinData . BI.dataToBuiltinData . toPlutusData) jsonDataM) :: Maybe (Maybe SwapConfig) - print test - print data' - pure () --- Minting policies stuff --- convertUplcMintingPolicy :: PoolInfo -> IO () @@ -555,19 +444,6 @@ convertUplcMintingPolicy pi@PoolInfo{..} = scr = PlutusScriptSerialised shortBS writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr pure () - lqBytes <- BS.readFile (uplcPolicyLqPath pi) - let - shortLqBS = SBS.toShort lqBytes - lqscr :: PlutusScript PlutusScriptV2 - lqscr = PlutusScriptSerialised shortLqBS - writeFileTextEnvelope (plutusLqPolicyPath pi) Nothing lqscr - nftBytes <- BS.readFile (uplcPolicyNftPath pi) - let - nftshortBS = SBS.toShort nftBytes - nftscr :: PlutusScript PlutusScriptV2 - nftscr = PlutusScriptSerialised nftshortBS - writeFileTextEnvelope (plutusNftPolicyPath pi) Nothing nftscr - pure () else pure () getPoolMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy @@ -577,24 +453,6 @@ getPoolMintingPolicy pi = do script = deserialise (LBS.fromStrict bytes) pure (PlutusV2.MintingPolicy script) -getPoolLQMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy -getPoolLQMintingPolicy pi = do - bytes <- BS.readFile (uplcPolicyLqPath pi) - let - script = deserialise (LBS.fromStrict bytes) - (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash (PlutusV2.MintingPolicy script) - mpCS = CurrencySymbol mpPolicyHash - pure (PlutusV2.MintingPolicy script) - -getPoolNftMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy -getPoolNftMintingPolicy pi = do - bytes <- BS.readFile (uplcPolicyNftPath pi) - let - script = deserialise (LBS.fromStrict bytes) - (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash (PlutusV2.MintingPolicy script) - mpCS = CurrencySymbol mpPolicyHash - pure (PlutusV2.MintingPolicy script) - --- Staking scripts stuff --- convertUplcStakingScript :: String -> IO () From 3ecac97075b4f7872d80b22136f0208a5de7fda1 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Tue, 29 Aug 2023 12:18:59 +0200 Subject: [PATCH 26/50] add json instances for v1|v2 --- dex-core/src/ErgoDex/Validators.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/dex-core/src/ErgoDex/Validators.hs b/dex-core/src/ErgoDex/Validators.hs index 3df54afc..0015ba72 100644 --- a/dex-core/src/ErgoDex/Validators.hs +++ b/dex-core/src/ErgoDex/Validators.hs @@ -15,16 +15,18 @@ module ErgoDex.Validators ) where import Control.Monad.IO.Class (MonadIO) -import RIO ((<&>)) +import RIO ((<&>), Generic) import qualified Plutus.V2.Ledger.Api as PV2 import ErgoDex.PValidators ( depositValidator, poolValidator, redeemValidator, swapValidator ) +import Data.Aeson newtype PoolValidator ver = PoolValidator PV2.Validator data Version = V1 | V2 + deriving (Generic, Eq, Show, FromJSON, ToJSON) data SwapK data DepositK @@ -46,16 +48,16 @@ orderValidator (RedeemValidator rv) = rv type AnyOrderValidator ver = forall kind. OrderValidator kind ver -type PoolValidatorV1 = PoolValidator V1 +type PoolValidatorV1 = PoolValidator 'V1 -fetchPoolValidatorV1 :: MonadIO m => m (PoolValidator V1) +fetchPoolValidatorV1 :: MonadIO m => m (PoolValidator 'V1) fetchPoolValidatorV1 = poolValidator <&> PoolValidator -fetchSwapValidatorV1 :: MonadIO m => m (SwapValidator V1) +fetchSwapValidatorV1 :: MonadIO m => m (SwapValidator 'V1) fetchSwapValidatorV1 = swapValidator <&> SwapValidator -fetchDepositValidatorV1 :: MonadIO m => m (DepositValidator V1) +fetchDepositValidatorV1 :: MonadIO m => m (DepositValidator 'V1) fetchDepositValidatorV1 = depositValidator <&> DepositValidator -fetchRedeemValidatorV1 :: MonadIO m => m (RedeemValidator V1) +fetchRedeemValidatorV1 :: MonadIO m => m (RedeemValidator 'V1) fetchRedeemValidatorV1 = redeemValidator <&> RedeemValidator From bb3299d354e55cec79e2993db9cb8e4a0e796974 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 1 Sep 2023 10:37:11 +0200 Subject: [PATCH 27/50] PoolValidator V2 --- dex-core/src/ErgoDex/Amm/Orders.hs | 4 +++ dex-core/src/ErgoDex/Amm/Pool.hs | 8 ++--- dex-core/src/ErgoDex/Amm/PoolActions.hs | 34 ++++++++++----------- submit-api/test/Main.hs | 39 ++++++++++++++++++++----- 4 files changed, 56 insertions(+), 29 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/Orders.hs b/dex-core/src/ErgoDex/Amm/Orders.hs index c1065382..fa75c2b1 100644 --- a/dex-core/src/ErgoDex/Amm/Orders.hs +++ b/dex-core/src/ErgoDex/Amm/Orders.hs @@ -37,6 +37,8 @@ data Swap = Swap , swapRewardSPkh :: Maybe StakePubKeyHash } deriving (Show, Eq, Generic, ToJSON, FromJSON) +-- 10 000 000 000 000 000 + instance FromLedger Swap where parseFromLedger fout@FullTxOut{fullTxOutDatum=(KnownDatum (Datum d)), ..} = case fromBuiltinData d of @@ -46,8 +48,10 @@ instance FromLedger Swap where baseIn = Amount $ assetClassValueOf fullTxOutValue base minBase = if isAda swapBase + -- 1000000 + (1199041 * 15011997087672564) / 10000000000000000 then baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen else baseAmount + -- 2 799 999 when (unAmount baseIn < minBase) Nothing Just $ OnChain fout Swap { swapPoolId = PoolId $ Coin poolNft diff --git a/dex-core/src/ErgoDex/Amm/Pool.hs b/dex-core/src/ErgoDex/Amm/Pool.hs index c7bce0d0..857fc9bc 100644 --- a/dex-core/src/ErgoDex/Amm/Pool.hs +++ b/dex-core/src/ErgoDex/Amm/Pool.hs @@ -90,7 +90,7 @@ instance FromLedger Pool where _ -> Nothing parseFromLedger _ = Nothing -instance ToLedger PoolValidatorV1 Pool where +instance ToLedger (PoolValidator ver) Pool where toLedger (PoolValidator poolValidator) Pool{..} = TxOutCandidate { txOutCandidateAddress = poolAddress @@ -159,7 +159,7 @@ initPool poolValidator S.PoolConfig{..} burnLq (inX, inY) = do pure (Predicted poolOut pool, releasedLq) -applyDeposit :: PoolValidator V1 -> Pool -> (Amount X, Amount Y) -> Predicted Pool +applyDeposit :: PoolValidator ver -> Pool -> (Amount X, Amount Y) -> Predicted Pool applyDeposit poolValidator p@Pool{..} (inX, inY) = Predicted nextPoolOut nextPool where @@ -187,7 +187,7 @@ rewardLp p@Pool{poolLiquidity=(Amount lq), poolReservesX=(Amount poolX), poolRes else (Amount $ (minByX - minByY) * poolX `div` lq, Amount 0) unlockedLq = Amount (min minByX minByY) -applyRedeem :: PoolValidator V1 -> Pool -> Amount Liquidity -> Predicted Pool +applyRedeem :: PoolValidator ver -> Pool -> Amount Liquidity -> Predicted Pool applyRedeem poolValidator p@Pool{..} burnedLq = Predicted nextPoolOut nextPool where @@ -200,7 +200,7 @@ applyRedeem poolValidator p@Pool{..} burnedLq = } nextPoolOut = toLedger poolValidator nextPool -applySwap :: PoolValidator V1 -> Pool -> AssetAmount Base -> Predicted Pool +applySwap :: PoolValidator ver -> Pool -> AssetAmount Base -> Predicted Pool applySwap poolValidator p@Pool{..} base = Predicted nextPoolOut nextPool where diff --git a/dex-core/src/ErgoDex/Amm/PoolActions.hs b/dex-core/src/ErgoDex/Amm/PoolActions.hs index d7a3739d..f5f5081f 100644 --- a/dex-core/src/ErgoDex/Amm/PoolActions.hs +++ b/dex-core/src/ErgoDex/Amm/PoolActions.hs @@ -81,7 +81,7 @@ fetchValidatorsV1 = <*> fetchDepositValidatorV1 <*> fetchRedeemValidatorV1 -data PoolActions = PoolActions +data PoolActions ver = PoolActions { runSwapWithDebug :: [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) , runDepositWithDebug :: [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) , runRedeemWithDebug :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either (OrderExecErr, OrderInfo) (TxCandidate, Predicted Pool, OrderInfo) @@ -90,7 +90,7 @@ data PoolActions = PoolActions , runRedeem :: [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) -> Either OrderExecErr (TxCandidate, Predicted Pool, Integer) } -mkPoolActions :: UnsafeEvalConfig -> PaymentPubKeyHash -> AmmValidators V1 -> PoolActions +mkPoolActions :: UnsafeEvalConfig -> PaymentPubKeyHash -> AmmValidators ver -> PoolActions ver mkPoolActions evalCfg executorPkh AmmValidators{..} = PoolActions { runSwapWithDebug = runSwapWithDebug' executorPkh poolV swapV , runDepositWithDebug = runDepositWithDebug' executorPkh poolV depositV @@ -104,9 +104,9 @@ newtype PoolIn = PoolIn FullTxOut newtype OrderIn = OrderIn FullTxOut mkOrderInputs - :: forall kind. P.PoolAction - -> PoolValidator V1 - -> OrderValidator kind V1 + :: forall ver kind. P.PoolAction + -> PoolValidator ver + -> OrderValidator kind ver -> PoolIn -> OrderIn -> Set.Set FullTxIn @@ -123,8 +123,8 @@ mkOrderInputs action (PoolValidator pv) ov' (PoolIn poolOut) (OrderIn orderOut) runSwapUnsafe' :: UnsafeEvalConfig -> PaymentPubKeyHash - -> PoolValidator V1 - -> SwapValidator V1 + -> PoolValidator ver + -> SwapValidator ver -> [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) @@ -183,8 +183,8 @@ runSwapUnsafe' UnsafeEvalConfig{..} executorPkh pv sv refInputs (OnChain swapOut runDepositUnsafe' :: UnsafeEvalConfig -> PaymentPubKeyHash - -> PoolValidator V1 - -> DepositValidator V1 + -> PoolValidator ver + -> DepositValidator ver -> [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) @@ -260,8 +260,8 @@ runDepositUnsafe' UnsafeEvalConfig{..} executorPkh pv dv refInputs (OnChain depo runRedeemUnsafe' :: UnsafeEvalConfig -> PaymentPubKeyHash - -> PoolValidator V1 - -> RedeemValidator V1 + -> PoolValidator ver + -> RedeemValidator ver -> [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) @@ -321,8 +321,8 @@ runRedeemUnsafe' UnsafeEvalConfig{..} executorPkh pv rv refInputs (OnChain redee runSwapWithDebug' :: PaymentPubKeyHash - -> PoolValidator V1 - -> SwapValidator V1 + -> PoolValidator ver + -> SwapValidator ver -> [FullTxOut] -> OnChain Swap -> (FullTxOut, Pool) @@ -385,8 +385,8 @@ runSwapWithDebug' executorPkh pv sv refInputs (OnChain swapOut s@Swap{swapExFee= runDepositWithDebug' :: PaymentPubKeyHash - -> PoolValidator V1 - -> DepositValidator V1 + -> PoolValidator ver + -> DepositValidator ver -> [FullTxOut] -> OnChain Deposit -> (FullTxOut, Pool) @@ -473,8 +473,8 @@ runDepositWithDebug' executorPkh pv dv refInputs (OnChain depositOut d@Deposit{. runRedeemWithDebug' :: PaymentPubKeyHash - -> PoolValidator V1 - -> RedeemValidator V1 + -> PoolValidator ver + -> RedeemValidator ver -> [FullTxOut] -> OnChain Redeem -> (FullTxOut, Pool) diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 1d775423..dd2f8f23 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -54,6 +54,10 @@ import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) +import ErgoDex.Contracts.Proxy.Swap (SwapConfig(SwapConfig, baseAmount, base)) +import ErgoDex.Contracts.Types (Amount(unAmount, Amount), Coin (Coin)) +import CardanoTx.Models (FullTxOut(fullTxOutValue)) +import PlutusTx.Prelude (divide) data TokenInfo = TokenInfo @@ -248,21 +252,40 @@ test3 = do pure () test123 = do - let - trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") - vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO + -- let + -- trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") + -- vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO - mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes + -- mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes - pkh <- getPaymentKeyHash vault + -- pkh <- getPaymentKeyHash vault - let - address = (mkPCred pkh) + -- let + -- address = (mkPCred pkh) - print address + -- print address -- defaultMain tests let + + testData = BuiltinData $ deserialise $ LBS.fromStrict $ mkByteString $ T.pack "d8799fd8799f4040ffd8799f581c533bb94a8850ee3ccbe483106489399112b74c905342cb1792a797a044494e4459ffd8799f581cd0861c6a8e913001a9ceaca2c8f3d403c7ed541e27fab570c0d17a324c494e44495f4144415f4e4654ff1903e51b00355554f1c7a8f41b002386f26fc10000581cc06d3c6c1fd24aab874cfb35a7fe5d090a501e4df0d9a58d00fd5678d8799f581c63481073ae1ea98b21c55b4ea2ab133ad85288c67b51c06edea79459ff1a000f42401a00124bc1ff" + + case fromBuiltinData testData of + (Just SwapConfig{..}) -> do + let + swapBase = Coin base + baseIn = Amount 4800000 + minBase = + if True + -- 1000000 + (1199041 * 15011997087672564) / 10000000000000000 + then baseAmount + divide (1199041 * 15011997087672564) 10000000000000000 + else baseAmount + -- 2 799 999 + print (unAmount baseIn < minBase) + _ -> print "test-" + + let + wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" From 5984bae734dc7d2bb4881ee2a6ea899e7a792e83 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 15 Sep 2023 11:00:38 +0200 Subject: [PATCH 28/50] lbsp tx balancer. wip --- submit-api/src/SubmitAPI/Config.hs | 3 + .../src/SubmitAPI/Internal/Balancing.hs | 86 +++-- .../src/SubmitAPI/Internal/Transaction.hs | 5 +- submit-api/src/SubmitAPI/Service.hs | 2 +- submit-api/submit-api.cabal | 1 + submit-api/test/Main.hs | 305 +++++++----------- submit-api/test/Spec/Transaction.hs | 5 +- 7 files changed, 185 insertions(+), 222 deletions(-) diff --git a/submit-api/src/SubmitAPI/Config.hs b/submit-api/src/SubmitAPI/Config.hs index 2b62cd1c..8d13d612 100644 --- a/submit-api/src/SubmitAPI/Config.hs +++ b/submit-api/src/SubmitAPI/Config.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} module SubmitAPI.Config ( FeePolicy(..) , CollateralPolicy(..) @@ -13,6 +14,7 @@ import GHC.Generics import Ledger (Address) import qualified Cardano.Api as C +import qualified Data.Text as T import qualified Ledger.Tx.CardanoAPI as Interop import CardanoTx.Models (ChangeAddress(..)) import Dhall (Natural) @@ -20,6 +22,7 @@ import Dhall (Natural) data FeePolicy = Strict -- Require existing TX inputs to cover fee entirely | Balance -- Allow adding new inputs to cover fee + | SplitBetween [T.Text] -- Generally for lbsp rewards distributionpurposes deriving Generic instance D.FromDhall FeePolicy diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 672e46d0..e915deda 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -2,7 +2,7 @@ module SubmitAPI.Internal.Balancing where import Prelude -import RIO.List (find) +import RIO.List (find, lastMaybe) import RIO (isJust) import Data.Bifunctor (first) import Data.Map (Map) @@ -17,7 +17,8 @@ import Cardano.Api.Shelley (ProtocolParameters(..), PoolId, ReferenceScript (. import qualified Cardano.Ledger.Coin as Ledger import Debug.Trace import Control.FromSum ( fromMaybe, maybeToEitherOr ) -import SubmitAPI.Config (UnsafeEvalConfig (..)) +import SubmitAPI.Config (UnsafeEvalConfig (..), FeePolicy (SplitBetween), TxAssemblyConfig (feePolicy)) +import qualified Ledger.Tx.CardanoAPI as Interop -- exUnitsMap:fromList [(ScriptWitnessIndexTxIn 0,Right (ExecutionUnits {executionSteps = 130605779, executionMemory = 298198})), -- (ScriptWitnessIndexTxIn 1,Right (ExecutionUnits {executionSteps = 133934187, executionMemory = 302164}))] @@ -29,7 +30,7 @@ makeTransactionBodyBalanceUnsafe -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Integer - -> Integer + -> Integer -> Either TxBodyErrorAutoBalance (BalancedTxBody era) makeTransactionBodyBalanceUnsafe cfg@UnsafeEvalConfig{..} txbodycontent changeaddr changeValue colAmount = do let era' = cardanoEra @@ -37,7 +38,7 @@ makeTransactionBodyBalanceUnsafe cfg@UnsafeEvalConfig{..} txbodycontent changead let fee = unsafeTxFee totalCollateral = TxTotalCollateral retColSup (Lovelace colAmount) - (retColl, reqCol) = + (retColl, reqCol) = ( TxReturnCollateralNone , totalCollateral ) @@ -63,7 +64,7 @@ substituteExecutionUnitsUnsafe UnsafeEvalConfig{..} = f _ (PlutusScriptWitness langInEra version script datum redeemer _) = Right $ PlutusScriptWitness langInEra version script datum redeemer (ExecutionUnits exUnits exMem) - + makeTransactionBodyAutoBalance :: forall era mode. IsShelleyBasedEra era @@ -76,9 +77,10 @@ makeTransactionBodyAutoBalance -> TxBodyContent BuildTx era -> AddressInEra era -- ^ Change address -> Maybe Word -- ^ Override key witnesses + -> FeePolicy -> Either TxBodyErrorAutoBalance (BalancedTxBody era) makeTransactionBodyAutoBalance eraInMode systemstart history pparams - poolids utxo txbodycontent changeaddr mnkeys = do + poolids utxo txbodycontent changeaddr mnkeys feePolicy = do -- Our strategy is to: -- 1. evaluate all the scripts to get the exec units, update with ex units @@ -86,10 +88,17 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- 3. update tx with fees -- 4. balance the transaction and update tx change output + let + -- todo: Add check for outputs with addresses from SplitBetween + -- if there are empty set of utxos with corresponding address => add to charge set + initChargeBoxes = case feePolicy of + (SplitBetween _) -> [] + _ -> [TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone] + txbody0 <- first TxBodyError $ makeTransactionBody txbodycontent { txOuts = - txOuts txbodycontent ++ [TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone] + txOuts txbodycontent ++ initChargeBoxes --TODO: think about the size of the change output -- 1,2,4 or 8 bytes? } @@ -126,15 +135,21 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- output and fee. Yes this means this current code will only work for -- final fee of less than around 4000 ada (2^32-1 lovelace) and change output -- of less than around 18 trillion ada (2^64-1 lovelace). - let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr + let + (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr + + -- todo: Add check for outputs with addresses from SplitBetween + -- if there are empty set of utxos with corresponding address => add to charge set + chargeBoxes = case feePolicy of + (SplitBetween _) -> [] + _ -> [TxOut changeaddr + (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1) + TxOutDatumNone ReferenceScriptNone + ] txbody1 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees $ Lovelace (2^(32 :: Integer) - 1), - txOuts = txOuts txbodycontent ++ - [TxOut changeaddr - (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1) - TxOutDatumNone ReferenceScriptNone - ], + txOuts = txOuts txbodycontent ++ chargeBoxes, txReturnCollateral = dummyCollRet, txTotalCollateral = dummyTotColl } @@ -183,11 +198,13 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees fee, txOuts = accountForNoChange + feePolicy (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) (txOuts txbodycontent), txReturnCollateral = retColl, txTotalCollateral = reqCol } + return (BalancedTxBody txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where era :: ShelleyBasedEra era @@ -249,28 +266,45 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams ) else (TxReturnCollateralNone, TxTotalCollateralNone) + addLovelaceToUtxo :: TxOut CtxTx era -> Lovelace -> TxOut CtxTx era + addLovelaceToUtxo (TxOut boxAddr prevValue d ref) toAdd = + let + newValue = + case prevValue of + TxOutAdaOnly supportedEra lovelace -> TxOutAdaOnly supportedEra (lovelace + toAdd) + TxOutValue multiSupport value -> TxOutValue multiSupport (value <> lovelaceToValue toAdd) + in TxOut boxAddr newValue d ref + -- In the event of spending the exact amount of lovelace in -- the specified input(s), this function excludes the change -- output. Note that this does not save any fees because by default -- the fee calculation includes a change address for simplicity and -- we make no attempt to recalculate the tx fee without a change address. - accountForNoChange :: TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era] - accountForNoChange change@(TxOut addr balance _ _) rest = - case txOutValueToLovelace balance of - Lovelace 0 -> rest + accountForNoChange :: FeePolicy -> TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era] + accountForNoChange policy change@(TxOut addr balance _ _) rest = + case (txOutValueToLovelace balance, policy) of + (Lovelace 0, _) -> rest + -- in this case we distibute charge between utxos with address from addresses set + (chargeLovelace, SplitBetween addresses) -> + let + chargeForSingleUser = (chargeLovelace `div` fromIntegral (length addresses)) + chargeForLastUser = if (chargeForSingleUser * fromIntegral (length addresses)) == chargeLovelace + then chargeForSingleUser + else chargeForSingleUser + 1 + addressesLast = lastMaybe addresses >>= deserialiseAddress (AsAddress AsShelleyAddr) <&> shelleyAddressInEra + addressesInit = catMaybes (init addresses <&> deserialiseAddress (AsAddress AsShelleyAddr)) <&> shelleyAddressInEra + updatedUtxos = map (\out@(TxOut boxAddr _ _ _) -> + if boxAddr `elem` addressesInit then addLovelaceToUtxo out chargeForSingleUser + else if Just boxAddr == addressesLast then addLovelaceToUtxo out chargeForLastUser + else out + ) rest + in updatedUtxos -- We append change at the end so a client can predict the indexes -- of the outputs - chargeLovelace -> + (chargeLovelace, _) -> let chargeUserBox = find (\(TxOut boxAddr _ _ _) -> boxAddr == addr) rest - updatedChargeUserBox = chargeUserBox <&> (\(TxOut boxAddr prevValue d ref) -> - let - newValue = - case prevValue of - TxOutAdaOnly supportedEra lovelace -> TxOutAdaOnly supportedEra (lovelace + chargeLovelace) - TxOutValue multiSupport value -> TxOutValue multiSupport (value <> lovelaceToValue chargeLovelace) - in TxOut boxAddr newValue d ref - ) + updatedChargeUserBox = chargeUserBox <&> (`addLovelaceToUtxo` chargeLovelace) outputs = case updatedChargeUserBox of Nothing -> rest ++ [change] diff --git a/submit-api/src/SubmitAPI/Internal/Transaction.hs b/submit-api/src/SubmitAPI/Internal/Transaction.hs index 7b9d1430..b4afc7ce 100644 --- a/submit-api/src/SubmitAPI/Internal/Transaction.hs +++ b/submit-api/src/SubmitAPI/Internal/Transaction.hs @@ -46,8 +46,9 @@ buildBalancedTx -> Sdk.ChangeAddress -> Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate + -> FeePolicy -> f (BalancedTxBody BabbageEra) -buildBalancedTx SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} = do +buildBalancedTx SystemEnv{..} refScriptsMap network defaultChangeAddr collateral txc@Sdk.TxCandidate{..} feePolicy = do let eraInMode = BabbageEraInCardanoMode witOverrides = Nothing txBody <- buildTxBodyContent pparams network refScriptsMap collateral txc @@ -56,7 +57,7 @@ buildBalancedTx SystemEnv{..} refScriptsMap network defaultChangeAddr collateral Just (Sdk.ReturnTo addr) -> Interop.toCardanoAddressInEra network addr _ -> Interop.toCardanoAddressInEra network $ Sdk.getAddress defaultChangeAddr absorbBalancingError $ - Balancing.makeTransactionBodyAutoBalance eraInMode sysstart eraHistory pparams pools inputsMap txBody changeAddr witOverrides + Balancing.makeTransactionBodyAutoBalance eraInMode sysstart eraHistory pparams pools inputsMap txBody changeAddr witOverrides feePolicy where absorbBalancingError (Left e) = throwM $ BalancingError $ T.pack $ displayError e absorbBalancingError (Right a) = pure a diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index d2dee5a7..9a124574 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -79,7 +79,7 @@ finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAsse sysenv <- getSystemEnv collaterals <- selectCollaterals utxos sysenv refScriptsMap network conf txc - (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTx sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc + (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTx sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc feePolicy let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) signatories = allInputs >>= getPkh diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index 1d3a0730..4875f3f0 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -82,6 +82,7 @@ library network-api, wallet-api, plutus-chain-index, + base16-bytestring, plutus-tx, plutus-ledger-api, plutus-ledger-constraints, diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index dd2f8f23..8680a8b4 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -28,7 +28,9 @@ import Plutus.V1.Ledger.Value (AssetClass(..), assetClassValueOf, flattenValue, import Plutus.V1.Ledger.Api import ErgoDex.PValidators import Cardano.CLI.Shelley.Run.Transaction -import Cardano.Api (writeFileTextEnvelope, Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema), InAnyCardanoEra (InAnyCardanoEra), EraInMode (BabbageEraInCardanoMode), IsShelleyBasedEra) +import qualified Ledger as P +import Cardano.Api.SerialiseTextEnvelope +import Cardano.Api (Error(displayError), ScriptDataJsonSchema (ScriptDataJsonDetailedSchema), InAnyCardanoEra (InAnyCardanoEra), EraInMode (BabbageEraInCardanoMode), IsShelleyBasedEra) import Cardano.Api.Shelley (PlutusScript (..), PlutusScriptV2, serialiseToRawBytes, TxInMode (TxInMode)) import qualified Plutus.V1.Ledger.Scripts as Plutus import qualified Cardano.Api as C @@ -54,10 +56,6 @@ import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) -import ErgoDex.Contracts.Proxy.Swap (SwapConfig(SwapConfig, baseAmount, base)) -import ErgoDex.Contracts.Types (Amount(unAmount, Amount), Coin (Coin)) -import CardanoTx.Models (FullTxOut(fullTxOutValue)) -import PlutusTx.Prelude (divide) data TokenInfo = TokenInfo @@ -88,6 +86,8 @@ data PoolInfo = PoolInfo , allowStaking :: Bool } + + lqInitQty = 9223372036854775807 workDir :: String @@ -99,6 +99,9 @@ mintingPolicyNamePostfix = "_mintingPolicy" stakingScriptNamePostfix :: String stakingScriptNamePostfix = "_stakingScript" +mintingPolicyNFTNamePostfix = "_mintingPolicyNFT" +mintingPolicyLQNamePostfix = "_mintingPolicyLQ" + poolDatumPostfix :: String poolDatumPostfix = "_poolDatum" @@ -114,9 +117,21 @@ jsonExtension = ".json" uplcPolicyPath :: PoolInfo -> String uplcPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ uplcExtension +uplcPolicyLqPath :: PoolInfo -> String +uplcPolicyLqPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ uplcExtension + +uplcPolicyNftPath :: PoolInfo -> String +uplcPolicyNftPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ uplcExtension + plutusPolicyPath :: PoolInfo -> String plutusPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNamePostfix ++ plutusExtension +plutusNftPolicyPath :: PoolInfo -> String +plutusNftPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyNFTNamePostfix ++ plutusExtension + +plutusLqPolicyPath :: PoolInfo -> String +plutusLqPolicyPath PoolInfo{..} = workDir ++ name ++ mintingPolicyLQNamePostfix ++ plutusExtension + uplcStakingScriptPath :: String -> String uplcStakingScriptPath pkh = workDir ++ pkh ++ stakingScriptNamePostfix ++ uplcExtension @@ -149,196 +164,50 @@ eraseLeft :: Either a b -> Either () b eraseLeft (Right l) = Right l eraseLeft (Left _) = Left () -test3 = do - deposit <- depositValidator - - let - depositAddress = PV2.mkValidatorAddress deposit - - inputAda = lovelaceValueOf 11929173 - - snekAssetClass = tokenInfo2CS $ TokenInfo "279c909f348e533da5808898f87f9a14bb2c3dfbbacccd631d927a3f" "534e454b" - inputSnek = assetClassValue snekAssetClass 10000 - - poolNft = tokenInfo2CS $ TokenInfo "4a27465112a39464e6dd5ee470c552ebb3cb42925d5ec04014967908" "534E454B5F4144415F4E4654" - poolLp = tokenInfo2CS $ TokenInfo "7bddf2c27f257eeeef3e892758b479e09c89a73642499797f2a97f3c" "534E454B5F4144415F4C51" - - inputDatum = DepositConfig - { poolNft = poolNft - , tokenA = tokenInfo2CS adaTokenInfo - , tokenB = snekAssetClass - , tokenLp = poolLp - , exFee = 1500000 - , rewardPkh = PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "719bee424a97b58b3dca88fe5da6feac6494aa7226f975f3506c5b25" - , stakePkh = Just $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "7846f6bb07f5b2825885e4502679e699b4e60a0c4609a46bc35454cd" - , collateralAda = 0 - } - - refundInput = PV2L.TxInInfo { - txInInfoOutRef = TxOutRef { - txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "818804916028d33eef09eb2c5dac47d2c38094eeba21daac65c1627afd82884d", - txOutRefIdx = 0 - }, - txInInfoResolved = PlutusV2.TxOut { - txOutAddress = depositAddress, - txOutValue = inputAda <> inputSnek, - txOutDatum = OutputDatum $ Datum $ toBuiltinData inputDatum, - txOutReferenceScript = Just $ scriptHash (unValidatorScript deposit) - } - } - - unknownReferenceInput = refundInput - - depositRefInputAda = lovelaceValueOf 1226634 - - depositReferenceInput = PV2L.TxInInfo { - txInInfoOutRef = TxOutRef { - txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "fc9e99fd12a13a137725da61e57a410e36747d513b965993d92c32c67df9259a", - txOutRefIdx = 0 - }, - txInInfoResolved = PlutusV2.TxOut { - txOutAddress = Address - (PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea") - (Just $ StakingHash $ PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "3f70ef0595dbc750d6575d814af8da0cdb53e778dae4895e85ef239e"), - txOutValue = depositRefInputAda, - txOutDatum = NoOutputDatum, - txOutReferenceScript = Nothing - } - } - - userTxOutAda = lovelaceValueOf 10452541 - - userTxOut = PlutusV2.TxOut { - txOutAddress = Address - (PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "21bcdaa800d642aa94d62ab43524de3481a7790b69172e7e3ef882ec") - (Just $ StakingHash $ PubKeyCredential $ PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "7846f6bb07f5b2825885e4502679e699b4e60a0c4609a46bc35454cd"), - txOutValue = userTxOutAda <> inputSnek, - txOutDatum = NoOutputDatum, - txOutReferenceScript = Nothing - } - - spendingRef = TxOutRef { - txOutRefId = TxId $ BuiltinByteString $ mkByteString $ T.pack "818804916028d33eef09eb2c5dac47d2c38094eeba21daac65c1627afd82884d", - txOutRefIdx = 0 - } - - orderRedeemer = toBuiltinData $ OrderRedeemer 0 0 0 Refund - - txId = TxId $ BuiltinByteString $ mkByteString $ T.pack "349709cb602d3ae5405e8fba4888c4f31706345c183014efe1b5388447aadca8" - - ctx = PV2L.TxInfo - { txInfoInputs = [refundInput] -- ^ Transaction inputs - , txInfoReferenceInputs = [unknownReferenceInput, depositReferenceInput] -- ^ Transaction reference inputs - , txInfoOutputs = [userTxOut] -- ^ Transaction outputs - , txInfoFee = lovelaceValueOf 1476632 -- ^ The fee paid by this transaction. - , txInfoMint = lovelaceValueOf 0 -- ^ The 'Value' minted by this transaction. - , txInfoDCert = [] -- ^ Digests of certificates included in this transaction - , txInfoWdrl = Map.empty -- ^ Withdrawals - , txInfoValidRange = Interval.always -- ^ The valid range for the transaction. - , txInfoSignatories = [ - PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "21bcdaa800d642aa94d62ab43524de3481a7790b69172e7e3ef882ec", - PubKeyHash $ BuiltinByteString $ mkByteString $ T.pack "719bee424a97b58b3dca88fe5da6feac6494aa7226f975f3506c5b25" -- collateral signature + datum - ] -- ^ Signatures provided with the transaction, attested that they all signed the tx - , txInfoRedeemers = Map.fromList [(Spending spendingRef, Redeemer orderRedeemer)] - , txInfoData = Map.empty - , txInfoId = txId - -- ^ Hash of the pending transaction (excluding witnesses) - } - - print depositAddress - - print $ show $ toBuiltinData ctx - -- print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" - pure () - test123 = do - -- let - -- trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/wallet1TS.json") - -- vault = mkVault trustStore $ KeyPass $ T.pack "test1234" :: Vault IO - - -- mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes - - -- pkh <- getPaymentKeyHash vault - - -- let - -- address = (mkPCred pkh) + print $ "test" + print $ readShellyAddress "addr1wyqnt3mp3fc75mseaw74j2zxz4l3rj8uaujp20cuz7jva6q2crsut" + let - -- print address + stablePkh :: P.PubKeyHash + stablePkh = PubKeyHash $ BuiltinByteString $ mkByteString "c8bf2748d61cf612fccc93287e475779ecd2c89f3e1b06da3ac4aa19" - -- defaultMain tests - let + testAddr = P.pubKeyHashAddress (P.PaymentPubKeyHash stablePkh) Nothing - testData = BuiltinData $ deserialise $ LBS.fromStrict $ mkByteString $ T.pack "d8799fd8799f4040ffd8799f581c533bb94a8850ee3ccbe483106489399112b74c905342cb1792a797a044494e4459ffd8799f581cd0861c6a8e913001a9ceaca2c8f3d403c7ed541e27fab570c0d17a324c494e44495f4144415f4e4654ff1903e51b00355554f1c7a8f41b002386f26fc10000581cc06d3c6c1fd24aab874cfb35a7fe5d090a501e4df0d9a58d00fd5678d8799f581c63481073ae1ea98b21c55b4ea2ab133ad85288c67b51c06edea79459ff1a000f42401a00124bc1ff" + print $ "Test pkh:" ++ show testAddr - case fromBuiltinData testData of - (Just SwapConfig{..}) -> do - let - swapBase = Coin base - baseIn = Amount 4800000 - minBase = - if True - -- 1000000 + (1199041 * 15011997087672564) / 10000000000000000 - then baseAmount + divide (1199041 * 15011997087672564) 10000000000000000 - else baseAmount - -- 2 799 999 - print (unAmount baseIn < minBase) - _ -> print "test-" - let + wallet1PubKeyHash = "a78c50e7b7c4ebff6881701d3ae48198dcdbab1b731d77139e33f3d0" + wallet2PubKeyHash = "6b4f0eace88f760261eddd8495bf4b8e3ae9743e7b65674deb90885d" + wallet3PubKeyHash = "add49ae8756c1f76e69ef87f598a8e6ad1eff47deab073cc979ad132" - wallet1PubKeyHash = "9b697975d20d891cc1713a3c4d3f881490880a780019337037ef079c" - wallet2PubKeyHash = "a6e1973e53af80c473cafb288235864f66240d305d9ce9df992125ea" - - mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash] + mintingSignatures = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] signaturesThreshold = 2 lqQty = 9223372036854775807 - rabbitPool = PoolInfo - { name = "rabbitPool" + tunapool = PoolInfo + { name = "tunaPool" , tokenX = adaTokenInfo - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6e6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745f6164615f6c71" - , lqBound = 5000000 - , authKeys = [] + , tokenY = TokenInfo "279f842c33eed9054b9e3c70cd6a3b32298259c24b78b895cb41d91a" "54554e41" + , tokenNft = TokenInfo "dd061b480daddd9a833d2477c791356be4e134a433e19df7eb18be10" "4f534f43494554595f4144415f4e4654" + , tokenLP = TokenInfo "c44de4596c7f4d600b631fab7ef1363331168463d4229cbc75ca1889" "4b534f43494554595f5f4c51" + , lqBound = 0 + , authKeys = [wallet1PubKeyHash, wallet2PubKeyHash, wallet3PubKeyHash] , threshold = signaturesThreshold - , initialXQty = 15000000 - , initialYQty = 15000000 + , initialXQty = 50000000 + , initialYQty = 16666666667 , allowStaking = True } - goldfishPool = PoolInfo - { name = "goldfishPool" - , tokenX = adaTokenInfo - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6e6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676f6c64666973685f6164615f6c71" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 15000000 - , initialYQty = 15000000000 - , allowStaking = True - } - rabbitFoldfishPool = PoolInfo - { name = "rabbitGoldfishPool" - , tokenX = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "726162626974" - , tokenY = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "676F6C6466697368" - , tokenNft = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6E6674" - , tokenLP = TokenInfo "5ac3d4bdca238105a040a565e5d7e734b7c9e1630aec7650e809e34a" "7261626269745F676F6C64666973685F6C71" - , lqBound = 5000000 - , authKeys = [] - , threshold = signaturesThreshold - , initialXQty = 1000000 - , initialYQty = 1000000 - , allowStaking = False - } - pools = [rabbitPool, goldfishPool, rabbitFoldfishPool] + pools = [tunapool] -- Step 1. Converting uplc produced by cardano-contracts onchain repo to plutus - -- convertUplcMintingPolicy `traverse` pools + convertUplcMintingPolicy `traverse` pools + + -- printLpPolicy `traverse` pools + -- printNftPolicy `traverse` pools -- Step 1.5 (optional) @@ -346,14 +215,14 @@ test123 = do -- Step 2. Datums creation. Will produce output for cardano-cli. Also necessary to copy all datums from test to mainnet machine - -- createDatumJson `traverse` pools + --createDatumJson `traverse` pools -- Step 3. Require manual steps for creation staking certs -- Also we cannot retrive original min utxo value for inline datums. So, set it manually -- More Also, we cannot determine change. So, set it manually too -- let - -- poolAddressWithStaking = "addr1x9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evkqwx9ghwy6quk2fhu5g0ek8rth7z4zxr5ev975ph34q5fsq2amyd" + -- poolAddressWithStaking = "addr1x94ec3t25egvhqy2n265xfhq882jxhkknurfe9ny4rl9k6dj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrst84slu" -- poolAddress = "addr1w9cgs59t2hr5sphrv4gfuzxl323akly5z57qv07hq266evsg37dfw" -- -- on mainnet machine -- origDatumWorkDir = "/root/plutus-scripts-for-mainnet/test-pools/datums/" @@ -371,18 +240,15 @@ test123 = do -- end - --print $ readShellyAddress "addr1v8g2jvkr55vsqlteuu5x0052lgj3ak0ev5vs74dyu0fgahg92dth0" - - -- print $ readShellyAddress "addr1qxupdk69sdemdx80far0tsvrydz7zj67ydzxxujmv9srj3tcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsy8ugdz" + print $ readShellyAddress "stake17y4jylfjtqmnpjz4v3hwnl4etw72ghx24c6aj9xjut7af2gx5e8ca" - print $ readShellyAddress "addr1qxy8aeh2e77hgtrevn4p459m7qsqswfnkxck26g2cuanh2ncgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqf8en8" - print $ readShellyAddress "addr1q9cehmjzf2tmtzeae2y0uhdxl6kxf992wgn0ja0n2pk9kftcgmmtkpl4k2p93p0y2qn8ne5eknnq5rzxpxjxhs652nxsqwq3mt" + -- print $ readShellyAddress "addr1vxkafxhgw4kp7ahxnmu87kv23e4drml50h4tqu7vj7ddzvs03pqaf" -- let testData = "hgCYrxoAAyNhGQMsAQEZA+gZAjsAARkD6BlecQQBGQPoGCAaAAHKdhko6wQZWdgYZBlZ2BhkGVnYGGQZWdgYZBlZ2BhkGVnYGGQYZBhkGVnYGGQZTFEYIBoAAqz6GCAZtVEEGgADYxUZAf8AARoAAVw1GCAaAAeXdRk29AQCGgAC/5QaAAbqeBjcAAEBGQPoGW/2BAIaAAO9CBoAA07FGD4BGgAQLg8ZMSoBGgADLoAZAaUBGgAC2ngZA+gZzwYBGgABOjQYIBmo8RggGQPoGCAaAAE6rAEZ4UMEGQPoChoAAwIZGJwBGgADAhkYnAEaAAMgfBkB2QEaAAMwABkB/wEZzPMYIBn9QBggGf/VGCAZWB4YIBlAsxggGgABKt8YIBoAAv+UGgAG6ngY3AABARoAAQ+SGS2nAAEZ6rsYIBoAAv+UGgAG6ngY3AABARoAAv+UGgAG6ngY3AABARoAEbIsGgAF/d4AAhoADFBOGXcSBBoAHWr2GgABQlsEGgAEDGYABAAaAAFPqxggGgADI2EZAywBARmg3hggGgADPXYYIBl59BggGX+4GCAZqV0YIBl99xggGZWqGCAaAiOszAoaA3T2kxlKHwoaAlFehBmAswqCGgCYloAbAAAAAhhxGgBZBHFZBG4BAAAyMjIyMjIyMjIyMjIyMjIyMjIyMjIyIiUzMBUyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMlMzAvM3DpABABCZGRkZGSmZgaGbh1MzA0M3Dm60wNTA2ARSAAFIAAUgAkgABUzAlM3DmYFQBhgagPJABCpmBKZuvMDUAYwNQChUzAlM3DmZgZkRKZmBiACIAQmYAZm4AAJIAIwOQAUgAAFUgBBUzAlUzMDQzcOAEACKURUzMDQzcQAEACJmZmYEYB5gagOAAgBABgCiZmZmBGAeYGoDoAQAIAgAombiVMzA0M3EgBAAiAEIAJmBUAeYGoDYmZEZkYGxEpmYGYAIpQFTMwOTN15gdAAgBilETACMDsAE3UgAgBG6wwNTIwNzA3MDcwNzA3ABMDYBY3XGBqAyZmZmBGAQYGgDYAQAhutMDQBk3WmBoYGoC5mZmYEQA5gZgNgBABm60wMwGDdaYGZgaALGYE4BJgZAMmYEwBBgYgMmbgUg/v//////////ATMCUAcwMAFhYwMgAjApABN1RgWmBcAubqzIwLTAuMC8AEwLDAtABMC0AEzAmN1pgVADgFG6syMCowKzAsABMCkwKgATAqABMwIzdaYE4AoA5mRGRkZKZmBUZGRkpmYFpm4dIAIAITIyMlMzAwM3DpAAABClATN15unAEN04AJgZgBGBUACbqgBxMjIyUzMDAzcOkAEAEKUBM3Xm6cAQ3TgAmBmAEYFQAJuqAHMDAAIwJwATdUACIAQsZGRkZGSmZgXGbh0gAAAhMjIyMlMzAyM3DpAAABCZGRkZKZmBsZuHSACACFhM3SpAAAAmByAEYGAAJuqABMDMAEWMDUAIwLAATdUACYF4AImbpUgAgKTAxACMCgAE3VAAmBWYFhgWgAmBUYFgApurMjIyUzMCszcOkAEAELCpmYFZm483XGBYACAMJgWGBaYFwA4sYFwARgSgAm6oAEyMCkwKwATAoMCoAM3XGBMAUYEwBJmBCbrTAlABAEMCUAEwJAATAkAON1hgQgBG6wwIAAjAgMCAAEwIDAeAIMB4AEwHQATAcABMBsAEwGgATAZABMBkAQwGAARSYWIiIiM3EmbgzNwRm4EAQAMAIAEzANAGAFIiIiMjNwZm4JTMwFzIyUzAKM3Hm64wGjAbACN1xgNGA2ACJm483XGA0AEbrjAaABMBsAswGgBhM3AmbgQAQAwAhABAEAFMwDABgBSIzMBEAIAEAMUoGbpUgADMAE3UgBGYAJupACAIV0CRAQAiMjMwBAAzdcYBwAJuuMA4wDwATAPABIiMzMAQAJIAAjMzAFACSAAdabqwAQAyMAI3UgAkREZgFESmZgDgAiAKKmZgGmbrzAJMA4AEAYTAEMBEwDgARMAIwDwAQAVVz6XrgVXOkSmZgCmbiAAkgABYTMAMAIAEwASIlMzAFM3DgBJAACYAwAImYAZm4EAJIAIwBwASMjACIzACACABIwAiMwAgAgAVc0roVdERgBG6oAFVc8Gf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP/YeZ8AAAAB/9h5n9h5n5/YeZ/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/2Hmf2Hmf2HqfWBwHXgnrD6ieHcNGkbPFan9DfmCsXqZ7M48uF24g/9h6gP+iQKFAGgC2NddYHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej+hRFNORUsZJxDYe5/YeZ/YeZ9YHEonRlESo5Rk5t1e5HDFUuuzy0KSXV7AQBSWeQhMU05FS19BREFfTkZU/9h5n0BA/9h5n1gcJ5yQnzSOUz2lgIiY+H+aFLssPfu6zM1jHZJ6P0RTTkVL/9h5n1gce93ywn8lfu7vPoknWLR54JyJpzZCSZeX8ql/PEtTTkVLX0FEQV9MUf8aABbjYFgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJdh5n1gceEb2uwf1soJYheRQJnnmmbTmCgxGCaRrw1RUzf8A///YeoD///+f2Hmf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A/9h5n9h5n9h6n1gcB14J6w+onh3DRpGzxWp/Q35grF6mezOPLhduIP/YeoD/okChQBoAtjXXWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2Huf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP//2HqA///YeZ/YeZ/YeZ9YIPyemf0SoToTdyXaYeV6QQ42dH1RO5ZZk9ksMsZ9+SWa/wD/2Hmf2Hmf2HmfWBym4Zc+U6+AxHPK+yiCNYZPZiQNMF2c6d+ZISXq/9h5n9h5n9h5n1gcP3DvBZXbx1DWV12BSvjaDNtT53ja5Ilehe8jnv////+hQKFAGgC7K2TYeYDYeZ9YHAdeCesPqJ4dw0aRs8Vqf0N+YKxepnszjy4XbiD/////n9h5n9h5n9h5n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7P/YeZ/YeZ/YeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/////okChQBoAn5uEWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2HmA2HqA//+hQKFAGgAWmlOhQKFAAICg2Hmf2Hmf2HmA2HqA/9h5n9h7gNh6gP//n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7FgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJf+h2Hqf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A///YeZ8AAAAB/6DYeZ9YIDMW4vM4hWi8LBR8kV4+xSzqkd2A8PJeMjwpxJhhd4zB///Yep/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/////gggA" -- plutusData = Data.from testData - -- pool <- poolValidator - -- print (PV2.mkValidatorAddress pool) + pool <- poolValidator + print (PV2.mkValidatorAddress pool) -- swap <- swapValidator -- print (PV2.mkValidatorAddress swap) -- deposit <- depositValidator @@ -441,7 +307,7 @@ createDatumJson pi@PoolInfo{..} = do pure [mpCS] else pure [] - let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 995 policies lqBound + let poolConfig = PoolConfig convertedNft convertedX convertedY convertedLP 997 policies lqBound writeDatumToJson pi poolConfig pure () @@ -460,12 +326,37 @@ convertUplcMintingPolicy :: PoolInfo -> IO () convertUplcMintingPolicy pi@PoolInfo{..} = if allowStaking then do - bytes <- BS.readFile (uplcPolicyPath pi) + -- bytes <- BS.readFile (uplcPolicyPath pi) + -- let + -- shortBS = SBS.toShort bytes + -- scr :: PlutusScript PlutusScriptV2 + -- scr = PlutusScriptSerialised shortBS + -- writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr + lqBytes <- BS.readFile "/home/bromel/test-mainnet-pools/spfMinting.uplc" let - shortBS = SBS.toShort bytes - scr :: PlutusScript PlutusScriptV2 - scr = PlutusScriptSerialised shortBS - writeFileTextEnvelope (plutusPolicyPath pi) Nothing scr + shortLqBS = SBS.toShort lqBytes + lqscr :: PlutusScript PlutusScriptV2 + lqscr = PlutusScriptSerialised shortLqBS + script = deserialise (LBS.fromStrict lqBytes) + policy = (PlutusV2.MintingPolicy script) + -- writeFileTextEnvelope "/home/bromel/test-mainnet-pools/spfMinting.plutus" Nothing lqscr + let + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash policy + mpCS = CurrencySymbol mpPolicyHash + print $ "lq:" ++ show mpCS + -- nftBytes <- BS.readFile (uplcPolicyNftPath pi) + -- lqBytes <- BS.readFile (uplcPolicyLqPath pi) + -- let + -- shortLqBS = SBS.toShort lqBytes + -- lqscr :: PlutusScript PlutusScriptV2 + -- lqscr = PlutusScriptSerialised shortLqBS + -- writeFileTextEnvelope (plutusLqPolicyPath pi) Nothing lqscr + -- nftBytes <- BS.readFile (uplcPolicyNftPath pi) + -- let + -- nftshortBS = SBS.toShort nftBytes + -- nftscr :: PlutusScript PlutusScriptV2 + -- nftscr = PlutusScriptSerialised nftshortBS + -- writeFileTextEnvelope (plutusNftPolicyPath pi) Nothing nftscr pure () else pure () @@ -476,6 +367,38 @@ getPoolMintingPolicy pi = do script = deserialise (LBS.fromStrict bytes) pure (PlutusV2.MintingPolicy script) +printLpPolicy :: PoolInfo -> IO () +printLpPolicy pi = do + policy <- getPoolLqMintingPolicy pi + let + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash policy + mpCS = CurrencySymbol mpPolicyHash + print $ "lq:" ++ show mpCS + print mpCS + +printNftPolicy :: PoolInfo -> IO () +printNftPolicy pi = do + policy <- getPoolNftMintingPolicy pi + let + (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash policy + mpCS = CurrencySymbol mpPolicyHash + print $ "nft:" ++ show mpCS + print mpCS + +getPoolNftMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolNftMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyNftPath pi) + let + script = deserialise (LBS.fromStrict bytes) + pure (PlutusV2.MintingPolicy script) + +getPoolLqMintingPolicy :: PoolInfo -> IO PV2.MintingPolicy +getPoolLqMintingPolicy pi = do + bytes <- BS.readFile (uplcPolicyLqPath pi) + let + script = deserialise (LBS.fromStrict bytes) + pure (PlutusV2.MintingPolicy script) + --- Staking scripts stuff --- convertUplcStakingScript :: String -> IO () diff --git a/submit-api/test/Spec/Transaction.hs b/submit-api/test/Spec/Transaction.hs index cd5756da..de7a9c1b 100644 --- a/submit-api/test/Spec/Transaction.hs +++ b/submit-api/test/Spec/Transaction.hs @@ -24,6 +24,7 @@ import SubmitAPI.Internal.Transaction import CardanoTx.Models import CardanoTx.Interop as Interop import Cardano.Api.Shelley (NetworkId(Mainnet)) +import SubmitAPI.Config (FeePolicy(Strict)) inputsOrderPreservedBuildTxBody :: Property inputsOrderPreservedBuildTxBody = property $ do @@ -76,7 +77,7 @@ buildTxBodyContentTests = testGroup "BuildTxBodyContent" inputsOrderPreservedBalancing :: Property inputsOrderPreservedBalancing = property $ do txc <- forAll genPlainTxCandidate - (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc + (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc Strict let candidateInputs = Set.elems (txCandidateInputs txc) <&> (fullTxOutRef . fullTxInTxOut) balancedInputs = Interop.extractCardanoTxBodyInputs txb @@ -85,7 +86,7 @@ inputsOrderPreservedBalancing = property $ do outputsOrderPreservedBalancing :: Property outputsOrderPreservedBalancing = property $ do txc <- forAll genPlainTxCandidate - (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc + (C.BalancedTxBody txb _ _) <- buildBalancedTx staticSystemEnv mempty Mainnet (ChangeAddress stableAddress) mempty txc Strict let candidateOutputs = zip [0..] $ txCandidateOutputs txc balancedOutputs = Interop.extractCardanoTxBodyOutputs txb From d2924670ae1fbb64f2338313add258279e61660f Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 15 Sep 2023 16:35:30 +0200 Subject: [PATCH 29/50] http submit api draft --- network-api/network-api.cabal | 1 + network-api/src/NetworkAPI/Service.hs | 3 ++- submit-api/src/SubmitAPI/Service.hs | 13 ++++++++++--- submit-api/test/Main.hs | 2 +- 4 files changed, 14 insertions(+), 5 deletions(-) diff --git a/network-api/network-api.cabal b/network-api/network-api.cabal index fcd8fc12..ca389fd0 100644 --- a/network-api/network-api.cabal +++ b/network-api/network-api.cabal @@ -74,6 +74,7 @@ library exposed-modules: NetworkAPI.Types NetworkAPI.Service + NetworkAPI.HttpService build-depends: rio, diff --git a/network-api/src/NetworkAPI/Service.hs b/network-api/src/NetworkAPI/Service.hs index 42b4c4a4..d46c7064 100644 --- a/network-api/src/NetworkAPI/Service.hs +++ b/network-api/src/NetworkAPI/Service.hs @@ -77,7 +77,8 @@ submitTx' submitTx' Logging{..} era conn tx = case toEraInMode era CardanoMode of Just eraInMode -> do - let txInMode = TxInMode tx eraInMode + let + txInMode = TxInMode tx eraInMode res <- liftIO $ submitTxToNodeLocal conn txInMode case res of Net.Tx.SubmitSuccess -> infoM @String "Transaction successfully submitted." diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 9a124574..15a311e3 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -18,6 +18,8 @@ import NetworkAPI.Service hiding (submitTx) import qualified NetworkAPI.Service as Network import NetworkAPI.Types import WalletAPI.Utxos +import NetworkAPI.HttpService hiding (submitTx, submitTx') +import qualified NetworkAPI.HttpService as HttpApi import WalletAPI.Vault import Cardano.Crypto.DSIGN.SchnorrSecp256k1 import Cardano.Api (Lovelace(Lovelace)) @@ -26,12 +28,14 @@ import Plutus.V1.Ledger.Api (adaSymbol) import Plutus.V1.Ledger.Api (adaToken) import Ledger.Value (assetClassValueOf) import System.Logging.Hlog +import Cardano.Api.SerialiseTextEnvelope data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace , finalizeTx :: Sdk.TxCandidate -> f (C.Tx era) , finalizeTxUnsafe :: Sdk.TxCandidate -> Integer -> f (C.Tx era) - , submitTx :: C.Tx era -> f C.TxId + , submitTx :: C.Tx era -> f C.TxId + , submitTxByHttp :: C.Tx era -> f C.TxId } mkTransactions @@ -39,17 +43,19 @@ mkTransactions => UnsafeEvalConfig -> Logging f -> CardanoNetwork f C.BabbageEra + -> CardanoHttpNetwork f C.BabbageEra -> C.NetworkId -> Map P.Script C.TxIn -> WalletOutputs f -> Vault f -> TxAssemblyConfig -> Transactions f C.BabbageEra -mkTransactions cfg logging network networkId refScriptsMap utxos wallet conf = Transactions +mkTransactions cfg logging network httpNetwork networkId refScriptsMap utxos wallet conf = Transactions { estimateTxFee = estimateTxFee' network networkId refScriptsMap , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf , finalizeTxUnsafe = finalizeTxUnsafe' cfg logging network networkId refScriptsMap utxos wallet conf - , submitTx = submitTx' network + , submitTx = submitTx' network + , submitTxByHttp = HttpApi.submitTx httpNetwork } estimateTxFee' @@ -117,6 +123,7 @@ finalizeTxUnsafe' cfg Logging{..} CardanoNetwork{..} network refScriptsMap utxos submitTx' :: Monad f => CardanoNetwork f C.BabbageEra -> C.Tx C.BabbageEra -> f C.TxId submitTx' CardanoNetwork{submitTx} tx = do + let test = textEnvelopeToJSON Nothing tx submitTx tx pure . C.getTxId . C.getTxBody $ tx diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 8680a8b4..67c101dc 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -339,7 +339,7 @@ convertUplcMintingPolicy pi@PoolInfo{..} = lqscr = PlutusScriptSerialised shortLqBS script = deserialise (LBS.fromStrict lqBytes) policy = (PlutusV2.MintingPolicy script) - -- writeFileTextEnvelope "/home/bromel/test-mainnet-pools/spfMinting.plutus" Nothing lqscr + writeFileTextEnvelope "/home/bromel/test-mainnet-pools/spfMinting.plutus" Nothing lqscr let (PlutusV2.MintingPolicyHash mpPolicyHash) = mintingPolicyHash policy mpCS = CurrencySymbol mpPolicyHash From b0981e0ab9fcd4375215fd7b688c8538196d2218 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 15 Sep 2023 16:45:09 +0200 Subject: [PATCH 30/50] cleanuo --- network-api/src/NetworkAPI/HttpService.hs | 56 +++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 network-api/src/NetworkAPI/HttpService.hs diff --git a/network-api/src/NetworkAPI/HttpService.hs b/network-api/src/NetworkAPI/HttpService.hs new file mode 100644 index 00000000..1420602c --- /dev/null +++ b/network-api/src/NetworkAPI/HttpService.hs @@ -0,0 +1,56 @@ +module NetworkAPI.HttpService where + +import RIO + +import System.Logging.Hlog (Logging(..), MakeLogging(..)) +import Network.HTTP.Simple +import Cardano.Api hiding (SocketPath) +import qualified Data.ByteString.Lazy as LBS +import qualified Cardano.Api as C + +import Network.HTTP.Client.Conduit (Request(..)) + +data HttpServiceConfig = HttpServiceConfig + { submitUri :: String + } + +data CardanoHttpNetwork f era = CardanoHttpNetwork + { submitTx :: Tx era -> f C.TxId + } + +mkHttpCardanoNetwork + :: (MonadIO i, MonadThrow f, MonadUnliftIO f) + => MakeLogging i f + -> HttpServiceConfig + -> i (CardanoHttpNetwork f C.BabbageEra) +mkHttpCardanoNetwork MakeLogging{..} config = do + logging <- forComponent "CardanoNetwork" + pure $ CardanoHttpNetwork + { submitTx = submitTx' logging config + } + +submitTx' + :: (MonadIO f, MonadThrow f) + => Logging f + -> HttpServiceConfig + -> C.Tx C.BabbageEra + -> f C.TxId +submitTx' l@Logging{..} cfg tx = do + let TextEnvelope{..} = serialiseToTextEnvelope Nothing tx + mkPostRequest l cfg teRawCBOR >>= (\res -> infoM ("Submit result: " ++ show res)) >> pure (C.TxId "ea0f9abf50d396652d959ba5b2fde9409929043ff7f099e373e66f2226458a02") + +mkPostRequest :: (MonadIO f, MonadThrow f) => Logging f -> HttpServiceConfig -> ByteString -> f String +mkPostRequest Logging{..} HttpServiceConfig{..} tx = do + request <- parseRequest submitUri + + let req = setRequestBodyLBS (LBS.fromStrict tx) $ request + { method = "POST" + } + + response <- httpJSON req + + let parsedResponse = getResponseBody response + + debugM ("Response is: " ++ show parsedResponse) + + pure parsedResponse \ No newline at end of file From b3cf256cf20cebbb5bda2757aabedbaa8f92e45d Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 15 Sep 2023 16:53:43 +0200 Subject: [PATCH 31/50] add fromDhall instance for settings --- network-api/src/NetworkAPI/HttpService.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/network-api/src/NetworkAPI/HttpService.hs b/network-api/src/NetworkAPI/HttpService.hs index 1420602c..d376080f 100644 --- a/network-api/src/NetworkAPI/HttpService.hs +++ b/network-api/src/NetworkAPI/HttpService.hs @@ -10,9 +10,12 @@ import qualified Cardano.Api as C import Network.HTTP.Client.Conduit (Request(..)) +import Dhall + ( FromDhall) + data HttpServiceConfig = HttpServiceConfig { submitUri :: String - } + } deriving (Generic, FromDhall) data CardanoHttpNetwork f era = CardanoHttpNetwork { submitTx :: Tx era -> f C.TxId From 12bb33e60505dd038d5f84c2025321a842d88381 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sat, 16 Sep 2023 13:16:21 +0200 Subject: [PATCH 32/50] add content type --- network-api/src/NetworkAPI/HttpService.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/network-api/src/NetworkAPI/HttpService.hs b/network-api/src/NetworkAPI/HttpService.hs index d376080f..0f8a7375 100644 --- a/network-api/src/NetworkAPI/HttpService.hs +++ b/network-api/src/NetworkAPI/HttpService.hs @@ -46,14 +46,16 @@ mkPostRequest :: (MonadIO f, MonadThrow f) => Logging f -> HttpServiceConfig -> mkPostRequest Logging{..} HttpServiceConfig{..} tx = do request <- parseRequest submitUri - let req = setRequestBodyLBS (LBS.fromStrict tx) $ request + let req = addRequestHeader "Content-Type" "application/cbor" $ setRequestBodyLBS (LBS.fromStrict tx) $ request { method = "POST" } + infoM ("Request is: " ++ show req) + response <- httpJSON req let parsedResponse = getResponseBody response - debugM ("Response is: " ++ show parsedResponse) + infoM ("Response is: " ++ show parsedResponse) pure parsedResponse \ No newline at end of file From f9253ed7aa5a7f6f7d28df8f8c3ff48cfd97359a Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Sat, 16 Sep 2023 13:55:01 +0200 Subject: [PATCH 33/50] add errors --- network-api/src/NetworkAPI/HttpService.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/network-api/src/NetworkAPI/HttpService.hs b/network-api/src/NetworkAPI/HttpService.hs index 0f8a7375..6d6cd29f 100644 --- a/network-api/src/NetworkAPI/HttpService.hs +++ b/network-api/src/NetworkAPI/HttpService.hs @@ -12,6 +12,12 @@ import Network.HTTP.Client.Conduit (Request(..)) import Dhall ( FromDhall) +import Data.Text (isInfixOf, pack) + +data LocalSubmitException = BadInputsUtxo Text | BudgetError Text + deriving Show + +instance Exception LocalSubmitException data HttpServiceConfig = HttpServiceConfig { submitUri :: String @@ -50,12 +56,14 @@ mkPostRequest Logging{..} HttpServiceConfig{..} tx = do { method = "POST" } - infoM ("Request is: " ++ show req) - response <- httpJSON req let parsedResponse = getResponseBody response - infoM ("Response is: " ++ show parsedResponse) + if pack "BadInputsUTxO" `isInfixOf` pack parsedResponse + then throwM (BadInputsUtxo (pack parsedResponse)) + else if "The budget when the machine terminated was" `isInfixOf` pack parsedResponse + then throwM (BudgetError (pack parsedResponse)) + else pure () pure parsedResponse \ No newline at end of file From 71557902ce6364f9929e62e5e18f4b29a48a33ce Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 18 Sep 2023 13:02:13 +0200 Subject: [PATCH 34/50] change splitBetween logic --- .../src/SubmitAPI/Internal/Balancing.hs | 29 ++++++++++++++++--- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index e915deda..89590e64 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -146,10 +146,11 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams (lovelaceToTxOutValue $ Lovelace (2^(64 :: Integer)) - 1) TxOutDatumNone ReferenceScriptNone ] + outputs = txOuts txbodycontent ++ chargeBoxes txbody1 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees $ Lovelace (2^(32 :: Integer) - 1), - txOuts = txOuts txbodycontent ++ chargeBoxes, + txOuts = outputs, txReturnCollateral = dummyCollRet, txTotalCollateral = dummyTotColl } @@ -169,7 +170,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams txbody2 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { - txFee = TxFeeExplicit explicitTxFees fee + txFee = TxFeeExplicit explicitTxFees fee, + txOuts = updateOutputsWithFeePolicy feePolicy outputs fee } let balance = evaluateTransactionBalance pparams poolids utxo txbody2 @@ -197,10 +199,10 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees fee, - txOuts = accountForNoChange + txOuts = updateOutputsWithFeePolicy feePolicy (accountForNoChange feePolicy (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent), + (txOuts txbodycontent)) fee, txReturnCollateral = retColl, txTotalCollateral = reqCol } @@ -213,6 +215,25 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams era' :: CardanoEra era era' = cardanoEra + updateOutputsWithFeePolicy :: FeePolicy -> [TxOut CtxTx era] -> Lovelace -> [TxOut CtxTx era] + updateOutputsWithFeePolicy policy outputs finalFee = case policy of + SplitBetween addresses -> + let + feeByUser = finalFee `div` fromIntegral (length addresses) + lastUserFee = + if (feeByUser * fromIntegral (length addresses)) == finalFee + then feeByUser + else feeByUser + 1 + addressesLast = lastMaybe addresses >>= deserialiseAddress (AsAddress AsShelleyAddr) <&> shelleyAddressInEra + addressesInit = catMaybes (init addresses <&> deserialiseAddress (AsAddress AsShelleyAddr)) <&> shelleyAddressInEra + updatedUtxos = map (\out@(TxOut boxAddr _ _ _) -> + if boxAddr `elem` addressesInit then addLovelaceToUtxo out (negate feeByUser) + else if Just boxAddr == addressesLast then addLovelaceToUtxo out (negate lastUserFee) + else out + ) outputs + in updatedUtxos + _ -> outputs + calcReturnAndTotalCollateral :: Lovelace -- ^ Fee -> ProtocolParameters From 14a4237803a22fa914b7d70a524d9b6da8798a1b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 10:31:30 +0200 Subject: [PATCH 35/50] add debug --- dex-core/src/ErgoDex/Amm/Orders.hs | 2 -- .../src/SubmitAPI/Internal/Balancing.hs | 18 ++++++++++ submit-api/src/SubmitAPI/Service.hs | 8 ++--- submit-api/submit-api.cabal | 4 +++ submit-api/test/Main.hs | 33 ++++++++++++++++--- wallet-api/src/WalletAPI/TrustStore.hs | 6 ++-- 6 files changed, 59 insertions(+), 12 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/Orders.hs b/dex-core/src/ErgoDex/Amm/Orders.hs index fa75c2b1..e0a08940 100644 --- a/dex-core/src/ErgoDex/Amm/Orders.hs +++ b/dex-core/src/ErgoDex/Amm/Orders.hs @@ -48,10 +48,8 @@ instance FromLedger Swap where baseIn = Amount $ assetClassValueOf fullTxOutValue base minBase = if isAda swapBase - -- 1000000 + (1199041 * 15011997087672564) / 10000000000000000 then baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen else baseAmount - -- 2 799 999 when (unAmount baseIn < minBase) Nothing Just $ OnChain fout Swap { swapPoolId = PoolId $ Coin poolNft diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 89590e64..48f2a419 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -88,6 +88,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- 3. update tx with fees -- 4. balance the transaction and update tx change output + traceM $ "Going to balance tx:" + let -- todo: Add check for outputs with addresses from SplitBetween -- if there are empty set of utxos with corresponding address => add to charge set @@ -95,6 +97,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams (SplitBetween _) -> [] _ -> [TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone] + traceM $ "initChargeBoxes:" ++ show initChargeBoxes + txbody0 <- first TxBodyError $ makeTransactionBody txbodycontent { txOuts = @@ -103,6 +107,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- 1,2,4 or 8 bytes? } + traceM $ "txbody0:" ++ show txbody0 + exUnitsMap <- first TxBodyErrorValidityInterval $ evaluateTransactionExecutionUnits eraInMode @@ -127,6 +133,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $ txFeesExplicitInEra era' + traceM $ "explicitTxFees:" ++ show explicitTxFees + -- Make a txbody that we will use for calculating the fees. For the purpose -- of fees we just need to make a txbody of the right size in bytes. We do -- not need the right values for the fee or change output. We use @@ -155,6 +163,10 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams txTotalCollateral = dummyTotColl } + traceM $ "chargeBoxes:" ++ show chargeBoxes + traceM $ "outputs:" ++ show outputs + traceM $ "txbody1:" ++ show txbody1 + let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1) mnkeys fee = evaluateTransactionFee pparams txbody1 nkeys 0 --TODO: byron keys @@ -168,12 +180,16 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- Here we do not want to start with any change output, since that's what -- we need to calculate. + traceM $ "fee:" ++ show fee + txbody2 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees fee, txOuts = updateOutputsWithFeePolicy feePolicy outputs fee } + traceM $ "txbody2:" ++ show txbody2 + let balance = evaluateTransactionBalance pparams poolids utxo txbody2 mapM_ (`checkMinUTxOValue` pparams) $ txOuts txbodycontent1 @@ -207,6 +223,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams txTotalCollateral = reqCol } + traceM $ "txbody3:" ++ show txbody3 + return (BalancedTxBody txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee) where era :: ShelleyBasedEra era diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index 15a311e3..e3703ecf 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -51,11 +51,11 @@ mkTransactions -> TxAssemblyConfig -> Transactions f C.BabbageEra mkTransactions cfg logging network httpNetwork networkId refScriptsMap utxos wallet conf = Transactions - { estimateTxFee = estimateTxFee' network networkId refScriptsMap - , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf + { estimateTxFee = estimateTxFee' network networkId refScriptsMap + , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf , finalizeTxUnsafe = finalizeTxUnsafe' cfg logging network networkId refScriptsMap utxos wallet conf - , submitTx = submitTx' network - , submitTxByHttp = HttpApi.submitTx httpNetwork + , submitTx = submitTx' network + , submitTxByHttp = HttpApi.submitTx httpNetwork } estimateTxFee' diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index 4875f3f0..3b4a117e 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -94,6 +94,7 @@ library from-sum, plutus-ledger, bytestring, + ergo-hs-common, aeson, servant, singletons, @@ -133,6 +134,8 @@ test-suite submit-api-tests Gen.CardanoTx Spec.Network Spec.Transaction + TestDatum + build-depends: , base , HUnit @@ -161,6 +164,7 @@ test-suite submit-api-tests , cardano-ledger-shelley , cardano-ledger-babbage , submit-api + , ergo-hs-common , cardano-tx , network-api , wallet-api diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index 67c101dc..e9ca3f5a 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} + module Main where import qualified Data.Text.Encoding as E @@ -44,7 +45,6 @@ import CardanoTx.Address (readShellyAddress) import WalletAPI.Vault (Vault (getPaymentKeyHash), mkVault) import qualified Explorer.Types as Explorer import qualified Plutus.V1.Ledger.Api as P -import Cardano.Ledger.Alonzo.Data (Data(..)) import qualified Plutus.V1.Ledger.Bytes as Data import ErgoDex.Contracts.Proxy.Deposit (DepositConfig(..)) import Plutus.V2.Ledger.Tx (OutputDatum(..)) @@ -56,7 +56,10 @@ import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) - +import Common.Throw.Combinators (throwEither) +import ErgoDex.Contracts.Proxy.Swap (SwapConfig (..)) +import PlutusTx.Prelude (divide) +import TestDatum (LBSPDatum(LBSPDatum)) data TokenInfo = TokenInfo { curSymbol :: String @@ -165,6 +168,9 @@ eraseLeft (Right l) = Right l eraseLeft (Left _) = Left () test123 = do + + importTrustStoreFromCardano @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/lbspSecret.json") "/home/bromel/projects/cardano-dex-sdk-haskell/secret.skey" (KeyPass "lbsp") + print $ "test" print $ readShellyAddress "addr1wyqnt3mp3fc75mseaw74j2zxz4l3rj8uaujp20cuz7jva6q2crsut" let @@ -244,8 +250,20 @@ test123 = do -- print $ readShellyAddress "addr1vxkafxhgw4kp7ahxnmu87kv23e4drml50h4tqu7vj7ddzvs03pqaf" - -- let testData = "hgCYrxoAAyNhGQMsAQEZA+gZAjsAARkD6BlecQQBGQPoGCAaAAHKdhko6wQZWdgYZBlZ2BhkGVnYGGQZWdgYZBlZ2BhkGVnYGGQYZBhkGVnYGGQZTFEYIBoAAqz6GCAZtVEEGgADYxUZAf8AARoAAVw1GCAaAAeXdRk29AQCGgAC/5QaAAbqeBjcAAEBGQPoGW/2BAIaAAO9CBoAA07FGD4BGgAQLg8ZMSoBGgADLoAZAaUBGgAC2ngZA+gZzwYBGgABOjQYIBmo8RggGQPoGCAaAAE6rAEZ4UMEGQPoChoAAwIZGJwBGgADAhkYnAEaAAMgfBkB2QEaAAMwABkB/wEZzPMYIBn9QBggGf/VGCAZWB4YIBlAsxggGgABKt8YIBoAAv+UGgAG6ngY3AABARoAAQ+SGS2nAAEZ6rsYIBoAAv+UGgAG6ngY3AABARoAAv+UGgAG6ngY3AABARoAEbIsGgAF/d4AAhoADFBOGXcSBBoAHWr2GgABQlsEGgAEDGYABAAaAAFPqxggGgADI2EZAywBARmg3hggGgADPXYYIBl59BggGX+4GCAZqV0YIBl99xggGZWqGCAaAiOszAoaA3T2kxlKHwoaAlFehBmAswqCGgCYloAbAAAAAhhxGgBZBHFZBG4BAAAyMjIyMjIyMjIyMjIyMjIyMjIyMjIyIiUzMBUyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMlMzAvM3DpABABCZGRkZGSmZgaGbh1MzA0M3Dm60wNTA2ARSAAFIAAUgAkgABUzAlM3DmYFQBhgagPJABCpmBKZuvMDUAYwNQChUzAlM3DmZgZkRKZmBiACIAQmYAZm4AAJIAIwOQAUgAAFUgBBUzAlUzMDQzcOAEACKURUzMDQzcQAEACJmZmYEYB5gagOAAgBABgCiZmZmBGAeYGoDoAQAIAgAombiVMzA0M3EgBAAiAEIAJmBUAeYGoDYmZEZkYGxEpmYGYAIpQFTMwOTN15gdAAgBilETACMDsAE3UgAgBG6wwNTIwNzA3MDcwNzA3ABMDYBY3XGBqAyZmZmBGAQYGgDYAQAhutMDQBk3WmBoYGoC5mZmYEQA5gZgNgBABm60wMwGDdaYGZgaALGYE4BJgZAMmYEwBBgYgMmbgUg/v//////////ATMCUAcwMAFhYwMgAjApABN1RgWmBcAubqzIwLTAuMC8AEwLDAtABMC0AEzAmN1pgVADgFG6syMCowKzAsABMCkwKgATAqABMwIzdaYE4AoA5mRGRkZKZmBUZGRkpmYFpm4dIAIAITIyMlMzAwM3DpAAABClATN15unAEN04AJgZgBGBUACbqgBxMjIyUzMDAzcOkAEAEKUBM3Xm6cAQ3TgAmBmAEYFQAJuqAHMDAAIwJwATdUACIAQsZGRkZGSmZgXGbh0gAAAhMjIyMlMzAyM3DpAAABCZGRkZKZmBsZuHSACACFhM3SpAAAAmByAEYGAAJuqABMDMAEWMDUAIwLAATdUACYF4AImbpUgAgKTAxACMCgAE3VAAmBWYFhgWgAmBUYFgApurMjIyUzMCszcOkAEAELCpmYFZm483XGBYACAMJgWGBaYFwA4sYFwARgSgAm6oAEyMCkwKwATAoMCoAM3XGBMAUYEwBJmBCbrTAlABAEMCUAEwJAATAkAON1hgQgBG6wwIAAjAgMCAAEwIDAeAIMB4AEwHQATAcABMBsAEwGgATAZABMBkAQwGAARSYWIiIiM3EmbgzNwRm4EAQAMAIAEzANAGAFIiIiMjNwZm4JTMwFzIyUzAKM3Hm64wGjAbACN1xgNGA2ACJm483XGA0AEbrjAaABMBsAswGgBhM3AmbgQAQAwAhABAEAFMwDABgBSIzMBEAIAEAMUoGbpUgADMAE3UgBGYAJupACAIV0CRAQAiMjMwBAAzdcYBwAJuuMA4wDwATAPABIiMzMAQAJIAAjMzAFACSAAdabqwAQAyMAI3UgAkREZgFESmZgDgAiAKKmZgGmbrzAJMA4AEAYTAEMBEwDgARMAIwDwAQAVVz6XrgVXOkSmZgCmbiAAkgABYTMAMAIAEwASIlMzAFM3DgBJAACYAwAImYAZm4EAJIAIwBwASMjACIzACACABIwAiMwAgAgAVc0roVdERgBG6oAFVc8Gf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP/YeZ8AAAAB/9h5n9h5n5/YeZ/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/2Hmf2Hmf2HqfWBwHXgnrD6ieHcNGkbPFan9DfmCsXqZ7M48uF24g/9h6gP+iQKFAGgC2NddYHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej+hRFNORUsZJxDYe5/YeZ/YeZ9YHEonRlESo5Rk5t1e5HDFUuuzy0KSXV7AQBSWeQhMU05FS19BREFfTkZU/9h5n0BA/9h5n1gcJ5yQnzSOUz2lgIiY+H+aFLssPfu6zM1jHZJ6P0RTTkVL/9h5n1gce93ywn8lfu7vPoknWLR54JyJpzZCSZeX8ql/PEtTTkVLX0FEQV9MUf8aABbjYFgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJdh5n1gceEb2uwf1soJYheRQJnnmmbTmCgxGCaRrw1RUzf8A///YeoD///+f2Hmf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A/9h5n9h5n9h6n1gcB14J6w+onh3DRpGzxWp/Q35grF6mezOPLhduIP/YeoD/okChQBoAtjXXWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2Huf2Hmf2HmfWBxKJ0ZREqOUZObdXuRwxVLrs8tCkl1ewEAUlnkITFNORUtfQURBX05GVP/YeZ9AQP/YeZ9YHCeckJ80jlM9pYCImPh/mhS7LD37uszNYx2Sej9EU05FS//YeZ9YHHvd8sJ/JX7u7z6JJ1i0eeCciac2QkmXl/KpfzxLU05FS19BREFfTFH/GgAW42BYHHGb7kJKl7WLPcqI/l2m/qxklKpyJvl181BsWyXYeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/AP//2HqA///YeZ/YeZ/YeZ9YIPyemf0SoToTdyXaYeV6QQ42dH1RO5ZZk9ksMsZ9+SWa/wD/2Hmf2Hmf2HmfWBym4Zc+U6+AxHPK+yiCNYZPZiQNMF2c6d+ZISXq/9h5n9h5n9h5n1gcP3DvBZXbx1DWV12BSvjaDNtT53ja5Ilehe8jnv////+hQKFAGgC7K2TYeYDYeZ9YHAdeCesPqJ4dw0aRs8Vqf0N+YKxepnszjy4XbiD/////n9h5n9h5n9h5n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7P/YeZ/YeZ/YeZ9YHHhG9rsH9bKCWIXkUCZ55pm05goMRgmka8NUVM3/////okChQBoAn5uEWBwnnJCfNI5TPaWAiJj4f5oUuyw9+7rMzWMdkno/oURTTkVLGScQ2HmA2HqA//+hQKFAGgAWmlOhQKFAAICg2Hmf2Hmf2HmA2HqA/9h5n9h7gNh6gP//n1gcIbzaqADWQqqU1iq0NSTeNIGneQtpFy5+PviC7FgccZvuQkqXtYs9yoj+Xab+rGSUqnIm+XXzUGxbJf+h2Hqf2Hmf2HmfWCDiatkyzsIs4egknSDzGPMptdqbyLER1i2nb/2zM+z5l/8A///YeZ8AAAAB/6DYeZ9YIDMW4vM4hWi8LBR8kV4+xSzqkd2A8PJeMjwpxJhhd4zB///Yep/YeZ/YeZ9YIOJq2TLOwizh6CSdIPMY8ym12pvIsRHWLadv/bMz7PmX/wD/////gggA" - -- plutusData = Data.from testData + let + testData = "d8799fd8799f4040ffd8799f581c5d16cc1a177b5d9ba9cfa9793b07e60f1fb70fea1f8aef064415d11443494147ffd8799f581cb992582b95a3ee20cb4025699808c83caaefa7bae9387b72ba2c57c34b4941475f4144415f4e4654ff1903e51b003ec43ba36ca2901b8000000000000000581cf7d32615876de5429e8f4b596642977912d8c0638fccbe15784cec33d8799f581c75579cbeb4029bebe2a9bdeb7da16bd65bf8bfbe387f368464813cf2ff1a6f4312a61b00000001fa0fc783ff" + plutusDataE = (\bs -> deserialise (LBS.fromStrict bs) :: Data) `fmap` (Hex.decode . T.encodeUtf8 $ testData) + poolConfig = (\d -> (fromData d) :: Maybe SwapConfig) `fmap` plutusDataE + SwapConfig{..} = unsafeFromMaybe . unsafeFromEither $ poolConfig + test = baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen + + lbspDatum = LBSPDatum [[stablePkh, stablePkh], [stablePkh], [stablePkh, stablePkh]] + + print ("lbsp " ++ show ((Json.encode + . scriptDataToJson ScriptDataJsonDetailedSchema + . fromPlutusData + . toData + $ lbspDatum ))) pool <- poolValidator print (PV2.mkValidatorAddress pool) @@ -258,6 +276,9 @@ test123 = do pure () +-- 1870666662 +-- 1882929694 + -- poolDatum = PoolConfig spectrumTokenNFTClass spectrumTokenAClass spectrumTokenBClass spectrumTokenLPClass 995 -- poolDatumData = toData poolDatum @@ -428,6 +449,10 @@ unsafeFromEither :: (Show b) => Either b a -> a unsafeFromEither (Left err) = Prelude.error ("Err:" ++ show err) unsafeFromEither (Right value) = value +unsafeFromMaybe :: Maybe a -> a +unsafeFromMaybe Nothing = Prelude.error ("Err:") +unsafeFromMaybe (Just value) = value + -- writeDataDatum2 :: FilePath -> IO () -- writeDataDatum2 file = do -- LBS.writeFile file (Json.encode diff --git a/wallet-api/src/WalletAPI/TrustStore.hs b/wallet-api/src/WalletAPI/TrustStore.hs index 48c9c60b..f716d966 100644 --- a/wallet-api/src/WalletAPI/TrustStore.hs +++ b/wallet-api/src/WalletAPI/TrustStore.hs @@ -27,7 +27,8 @@ import qualified Cardano.Api as Crypto import WalletAPI.Internal.Crypto import WalletAPI.Internal.Models (SecretEnvelope(..), TrustStoreFile(..)) import Cardano.Api.Byron (AsType) -import Cardano.Api.Shelley (SerialiseAsRawBytes) +import Cardano.Api.Shelley (SerialiseAsRawBytes, castVerificationKey) +import Cardano.Api (castSigningKey) newtype SecretFile = SecretFile { unSigningKeyFile :: FilePath } deriving (Show, Eq, Generic) @@ -107,7 +108,8 @@ importTrustStoreFromCardano -> f (TrustStore f krole) importTrustStoreFromCardano krole targetFile srcFile pass = do sk <- absorbEnvelopeError =<< liftIO (Crypto.readFileTextEnvelope (Crypto.AsSigningKey krole) srcFile) - let vkEncoded = EncodedVK $ Crypto.serialiseToRawBytes $ Crypto.getVerificationKey sk + let + vkEncoded = EncodedVK $ Crypto.serialiseToRawBytes $ Crypto.getVerificationKey sk envelope <- encryptKey sk pass writeTS targetFile $ TrustStoreFile envelope vkEncoded pure $ mkTrustStore krole targetFile From c5d03ba8a2e4c1dc999c703043674438d5c809bd Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 10:36:48 +0200 Subject: [PATCH 36/50] add debug --- submit-api/submit-api.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/submit-api/submit-api.cabal b/submit-api/submit-api.cabal index 3b4a117e..381989a2 100644 --- a/submit-api/submit-api.cabal +++ b/submit-api/submit-api.cabal @@ -134,7 +134,6 @@ test-suite submit-api-tests Gen.CardanoTx Spec.Network Spec.Transaction - TestDatum build-depends: , base From 20714ae1786caa2390b0893bc9c2a34ffaea4881 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 11:16:45 +0200 Subject: [PATCH 37/50] remove explicit txOuts in txBody2 balancing process --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 48f2a419..5bcbc4b4 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -184,8 +184,8 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams txbody2 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { - txFee = TxFeeExplicit explicitTxFees fee, - txOuts = updateOutputsWithFeePolicy feePolicy outputs fee + txFee = TxFeeExplicit explicitTxFees fee + -- txOuts = outputs } traceM $ "txbody2:" ++ show txbody2 From 41e4e45134dc9a5584373ee0b1a3b5ee8b2544be Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 11:31:04 +0200 Subject: [PATCH 38/50] fix chargeBox merging --- submit-api/src/SubmitAPI/Internal/Balancing.hs | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 5bcbc4b4..09d75866 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -323,21 +323,6 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams accountForNoChange policy change@(TxOut addr balance _ _) rest = case (txOutValueToLovelace balance, policy) of (Lovelace 0, _) -> rest - -- in this case we distibute charge between utxos with address from addresses set - (chargeLovelace, SplitBetween addresses) -> - let - chargeForSingleUser = (chargeLovelace `div` fromIntegral (length addresses)) - chargeForLastUser = if (chargeForSingleUser * fromIntegral (length addresses)) == chargeLovelace - then chargeForSingleUser - else chargeForSingleUser + 1 - addressesLast = lastMaybe addresses >>= deserialiseAddress (AsAddress AsShelleyAddr) <&> shelleyAddressInEra - addressesInit = catMaybes (init addresses <&> deserialiseAddress (AsAddress AsShelleyAddr)) <&> shelleyAddressInEra - updatedUtxos = map (\out@(TxOut boxAddr _ _ _) -> - if boxAddr `elem` addressesInit then addLovelaceToUtxo out chargeForSingleUser - else if Just boxAddr == addressesLast then addLovelaceToUtxo out chargeForLastUser - else out - ) rest - in updatedUtxos -- We append change at the end so a client can predict the indexes -- of the outputs (chargeLovelace, _) -> From d180e1b192f22b4a2ffa7ee066fc73bb4ca929eb Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 16:39:26 +0200 Subject: [PATCH 39/50] fix filtering utxos in utxoStore --- wallet-api/src/WalletAPI/Utxos.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index 531600ee..5264033d 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -116,6 +116,7 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d _ -> Just acc + filterSpentedUtxos ustore explorer utxos <- getUtxos case collect [] mempty (Set.elems utxos) of Just outs -> pure $ Just $ Set.fromList outs From 858b6e3e3df1b6e8e621c88d97194a4ae19a5f28 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 17:12:42 +0200 Subject: [PATCH 40/50] add debug --- .../src/SubmitAPI/Internal/Balancing.hs | 28 +++++++++++++------ 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 09d75866..38195ca4 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -211,14 +211,17 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- fit within the encoding size we picked above when calculating the fee. -- Yes this could be an over-estimate by a few bytes if the fee or change -- would fit within 2^16-1. That's a possible optimisation. + + txBody3Outs <- updateOutputsWithFeePolicy feePolicy (accountForNoChange + feePolicy + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + (txOuts txbodycontent)) fee + txbody3 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees fee, - txOuts = updateOutputsWithFeePolicy feePolicy (accountForNoChange - feePolicy - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent)) fee, + txOuts = txBody3Outs, txReturnCollateral = retColl, txTotalCollateral = reqCol } @@ -233,9 +236,9 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams era' :: CardanoEra era era' = cardanoEra - updateOutputsWithFeePolicy :: FeePolicy -> [TxOut CtxTx era] -> Lovelace -> [TxOut CtxTx era] + updateOutputsWithFeePolicy :: FeePolicy -> [TxOut CtxTx era] -> Lovelace -> Either TxBodyErrorAutoBalance [TxOut CtxTx era] updateOutputsWithFeePolicy policy outputs finalFee = case policy of - SplitBetween addresses -> + SplitBetween addresses -> do let feeByUser = finalFee `div` fromIntegral (length addresses) lastUserFee = @@ -246,11 +249,18 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams addressesInit = catMaybes (init addresses <&> deserialiseAddress (AsAddress AsShelleyAddr)) <&> shelleyAddressInEra updatedUtxos = map (\out@(TxOut boxAddr _ _ _) -> if boxAddr `elem` addressesInit then addLovelaceToUtxo out (negate feeByUser) - else if Just boxAddr == addressesLast then addLovelaceToUtxo out (negate lastUserFee) + else if Just boxAddr == addressesLast then addLovelaceToUtxo out (negate lastUserFee) else out ) outputs - in updatedUtxos - _ -> outputs + traceM $ "feeByUser: " ++ show feeByUser + traceM $ "lastUserFee: " ++ show lastUserFee + traceM $ "addresses: " ++ show addresses + traceM $ "addressesLast: " ++ show addressesLast + traceM $ "addressesInit: " ++ show addressesInit + traceM $ "outputs: " ++ show outputs + traceM $ "updatedUtxos: " ++ show updatedUtxos + pure updatedUtxos + _ -> pure outputs calcReturnAndTotalCollateral :: Lovelace -- ^ Fee From 7d627d47fb3c3a580bfa544438d6eced938e16e0 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 18:46:37 +0200 Subject: [PATCH 41/50] add finalizeTxWithExplFeePolicy --- submit-api/src/SubmitAPI/Service.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index e3703ecf..bdf75c33 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -33,6 +33,7 @@ import Cardano.Api.SerialiseTextEnvelope data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace , finalizeTx :: Sdk.TxCandidate -> f (C.Tx era) + , finalizeTxWithExplFeePolicy :: FeePolicy -> Sdk.TxCandidate -> f (C.Tx era) , finalizeTxUnsafe :: Sdk.TxCandidate -> Integer -> f (C.Tx era) , submitTx :: C.Tx era -> f C.TxId , submitTxByHttp :: C.Tx era -> f C.TxId @@ -52,7 +53,8 @@ mkTransactions -> Transactions f C.BabbageEra mkTransactions cfg logging network httpNetwork networkId refScriptsMap utxos wallet conf = Transactions { estimateTxFee = estimateTxFee' network networkId refScriptsMap - , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf + , finalizeTx = finalizeTx' network networkId refScriptsMap utxos wallet conf (feePolicy conf) + , finalizeTxWithExplFeePolicy = finalizeTx' network networkId refScriptsMap utxos wallet conf , finalizeTxUnsafe = finalizeTxUnsafe' cfg logging network networkId refScriptsMap utxos wallet conf , submitTx = submitTx' network , submitTxByHttp = HttpApi.submitTx httpNetwork @@ -79,13 +81,14 @@ finalizeTx' -> WalletOutputs f -> Vault f -> TxAssemblyConfig + -> FeePolicy -> Sdk.TxCandidate -> f (C.Tx C.BabbageEra) -finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} txc@Sdk.TxCandidate{..} = do +finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAssemblyConfig{..} feeP txc@Sdk.TxCandidate{..} = do sysenv <- getSystemEnv collaterals <- selectCollaterals utxos sysenv refScriptsMap network conf txc - (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTx sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc feePolicy + (C.BalancedTxBody txb _ _) <- Internal.buildBalancedTx sysenv refScriptsMap network (getChangeAddr deafultChangeAddr) collaterals txc feeP let allInputs = (Set.elems txCandidateInputs <&> Sdk.fullTxInTxOut) ++ (Set.elems collaterals <&> Sdk.fullCollateralTxInTxOut) signatories = allInputs >>= getPkh From c940cbc5b902a110ff0b5e9012c65f96efff533d Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 20:27:37 +0200 Subject: [PATCH 42/50] change tx balancing --- .../src/SubmitAPI/Internal/Balancing.hs | 23 +++++++++++++------ 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/submit-api/src/SubmitAPI/Internal/Balancing.hs b/submit-api/src/SubmitAPI/Internal/Balancing.hs index 38195ca4..156c2a48 100644 --- a/submit-api/src/SubmitAPI/Internal/Balancing.hs +++ b/submit-api/src/SubmitAPI/Internal/Balancing.hs @@ -182,10 +182,14 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams traceM $ "fee:" ++ show fee + txBody2Outputs <- updateOutputsWithFeePolicy feePolicy (txOuts txbodycontent1) fee + + traceM $ "txBody2Outputs:" ++ show txBody2Outputs + txbody2 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { - txFee = TxFeeExplicit explicitTxFees fee - -- txOuts = outputs + txFee = TxFeeExplicit explicitTxFees fee, + txOuts = txBody2Outputs } traceM $ "txbody2:" ++ show txbody2 @@ -212,16 +216,21 @@ makeTransactionBodyAutoBalance eraInMode systemstart history pparams -- Yes this could be an over-estimate by a few bytes if the fee or change -- would fit within 2^16-1. That's a possible optimisation. - txBody3Outs <- updateOutputsWithFeePolicy feePolicy (accountForNoChange - feePolicy - (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) - (txOuts txbodycontent)) fee + traceM $ "tx balance:" ++ show balance + + -- txBody3Outs <- updateOutputsWithFeePolicy feePolicy (accountForNoChange + -- feePolicy + -- (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + -- (txBody2Outputs)) fee txbody3 <- first TxBodyError $ -- TODO: impossible to fail now makeTransactionBody txbodycontent1 { txFee = TxFeeExplicit explicitTxFees fee, - txOuts = txBody3Outs, + txOuts = accountForNoChange + feePolicy + (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) + (txBody2Outputs), txReturnCollateral = retColl, txTotalCollateral = reqCol } From cb4c9f1e52a0cf31eeac66ad23a53c792940d2f3 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 21:59:44 +0200 Subject: [PATCH 43/50] remove utxoStore usage for lbsp purposes --- wallet-api/src/WalletAPI/Utxos.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index 5264033d..eb1ebe96 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -116,9 +116,9 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d _ -> Just acc - filterSpentedUtxos ustore explorer - utxos <- getUtxos - case collect [] mempty (Set.elems utxos) of + -- filterSpentedUtxos ustore explorer + -- utxos <- getUtxos + case collect [] mempty mempty of Just outs -> pure $ Just $ Set.fromList outs Nothing -> fetchUtxos 0 batchSize >> selectUtxos'' logging explorer ustore pkh strict requiredValue where batchSize = 400 From 97154a165082046e2dc4d5c7c9bf1412094bae3b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 21 Sep 2023 22:22:01 +0200 Subject: [PATCH 44/50] fix filterSpentedUtxos --- wallet-api/src/WalletAPI/Utxos.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index eb1ebe96..f00ff10f 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -27,7 +27,7 @@ import qualified Explorer.Types as Explorer import qualified Explorer.Models as Explorer import qualified Explorer.Class as Explorer import Explorer.Types (PaymentCred) -import Explorer.Models (Paging, Items) +import Explorer.Models (Paging, Items, spentByTxHash) import Algebra.Natural import WalletAPI.UtxoStoreConfig (UtxoStoreConfig(..)) @@ -62,7 +62,8 @@ filterSpentedUtxos :: (Monad f) => UtxoStore f -> Explorer f -> f () filterSpentedUtxos UtxoStore{..} Explorer{..} = do allUtxos <- getUtxos (\FullTxOut{..} -> getOutput fullTxOutRef >>= (\case - Just _ -> pure () + Just utxo -> + if (isJust (spentByTxHash utxo)) then dropUtxos $ Set.fromList [fullTxOutRef] else pure () Nothing -> dropUtxos $ Set.fromList [fullTxOutRef] )) `traverse` toList allUtxos pure () @@ -116,9 +117,9 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d _ -> Just acc - -- filterSpentedUtxos ustore explorer - -- utxos <- getUtxos - case collect [] mempty mempty of + filterSpentedUtxos ustore explorer + utxos <- getUtxos + case collect [] mempty (Set.elems utxos) of Just outs -> pure $ Just $ Set.fromList outs Nothing -> fetchUtxos 0 batchSize >> selectUtxos'' logging explorer ustore pkh strict requiredValue where batchSize = 400 From 6f447da64eb23616f5ceabafc326abcd58dd3bf2 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 22 Sep 2023 10:25:01 +0200 Subject: [PATCH 45/50] mkSafeGetRequest --- quickblue/src/Explorer/Service.hs | 20 ++++++++++++++++++-- wallet-api/src/WalletAPI/Utxos.hs | 12 +++++++----- 2 files changed, 25 insertions(+), 7 deletions(-) diff --git a/quickblue/src/Explorer/Service.hs b/quickblue/src/Explorer/Service.hs index 72710465..bcecfa30 100644 --- a/quickblue/src/Explorer/Service.hs +++ b/quickblue/src/Explorer/Service.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} module Explorer.Service where import Control.Monad.IO.Class @@ -13,8 +14,9 @@ import Explorer.Config import Ledger ( TxOutRef, txOutRefId, txOutRefIdx ) import Prelude hiding (Ordering) -import System.Logging.Hlog (Logging (Logging, debugM), MakeLogging (MakeLogging, forComponent)) +import System.Logging.Hlog (Logging (Logging, debugM, infoM), MakeLogging (MakeLogging, forComponent)) import Common.String.Formatting (toLower) +import Control.Exception (handle, SomeException) data Explorer f = Explorer { getOutput :: TxOutRef -> f (Maybe FullTxOut) @@ -37,7 +39,7 @@ mkExplorer MakeLogging{..} conf = do getOutput' :: MonadIO f => Logging f -> ExplorerConfig -> TxOutRef -> f (Maybe FullTxOut) getOutput' logging conf@ExplorerConfig{..} ref = - mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/" ++ renderTxOutRef ref + mkSafeGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/" ++ renderTxOutRef ref getUnspentOutputs' :: MonadIO f => Logging f -> ExplorerConfig -> Gix -> Limit -> Ordering -> f (Items FullTxOut) getUnspentOutputs' logging conf@ExplorerConfig{..} minIndex limit ordering = @@ -66,5 +68,19 @@ mkGetRequest Logging{..} ExplorerConfig{..} path = do pure parsedResponse +mkSafeGetRequest :: (MonadIO f, FromJSON a) => Logging f -> ExplorerConfig -> String -> f (Maybe a) +mkSafeGetRequest Logging{..} ExplorerConfig{..} path = + liftIO $ handle @SomeException (\ex -> pure Nothing ) (do + let request = parseRequest_ (unUri explorerUri) & setRequestPath (Data.pack path) + + response <- httpJSON request + + let parsedResponse = getResponseBody response + + -- debugM ("Response is: " ++ show parsedResponse) + + pure $ Just parsedResponse + ) + renderTxOutRef :: TxOutRef -> [Char] renderTxOutRef ref = (show . txOutRefId $ ref) ++ T.unpack txOutRefSep ++ (show . txOutRefIdx $ ref) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index f00ff10f..cd97c2f6 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -41,7 +41,7 @@ data WalletOutputs f = WalletOutputs , selectUtxosStrict :: Value -> f (Maybe (Set.Set FullTxOut)) } -mkPersistentWalletOutputs :: +mkPersistentWalletOutputs :: ( MonadIO i , MonadIO f , MonadMask f @@ -61,8 +61,8 @@ mkPersistentWalletOutputs fToI mkLogging@MakeLogging{..} cfg explorer vaultF = d filterSpentedUtxos :: (Monad f) => UtxoStore f -> Explorer f -> f () filterSpentedUtxos UtxoStore{..} Explorer{..} = do allUtxos <- getUtxos - (\FullTxOut{..} -> getOutput fullTxOutRef >>= (\case - Just utxo -> + (\FullTxOut{..} -> getOutput fullTxOutRef >>= (\case + Just utxo -> if (isJust (spentByTxHash utxo)) then dropUtxos $ Set.fromList [fullTxOutRef] else pure () Nothing -> dropUtxos $ Set.fromList [fullTxOutRef] )) `traverse` toList allUtxos @@ -126,5 +126,7 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d getUnspentOutputsByPCredWithRetry :: (MonadIO f, MonadMask f) => Logging f -> Explorer f -> PaymentCred -> Paging -> f (Items Explorer.FullTxOut) getUnspentOutputsByPCredWithRetry Logging{..} Explorer{..} cred paging = do - let backoff = constantDelay 1000000 - recoverAll backoff (\rs -> infoM ("RetryStatus for getUnspentOutputsByPCredWithRetry " ++ (show rs)) >> (getUnspentOutputsByPCred cred paging)) \ No newline at end of file + let + -- backoff = constantDelay 1000000 + limitedBackoff = exponentialBackoff 50000 <> limitRetries 5 + recoverAll limitedBackoff (\rs -> infoM ("RetryStatus for getUnspentOutputsByPCredWithRetry " ++ show rs) >> getUnspentOutputsByPCred cred paging) \ No newline at end of file From 051a2a05dfc29df5bb8534da9588576d4e6ac265 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 22 Sep 2023 10:40:58 +0200 Subject: [PATCH 46/50] add debug --- quickblue/src/Explorer/Service.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/quickblue/src/Explorer/Service.hs b/quickblue/src/Explorer/Service.hs index bcecfa30..7465088a 100644 --- a/quickblue/src/Explorer/Service.hs +++ b/quickblue/src/Explorer/Service.hs @@ -60,11 +60,15 @@ mkGetRequest :: (MonadIO f, FromJSON a, Show a) => Logging f -> ExplorerConfig - mkGetRequest Logging{..} ExplorerConfig{..} path = do let request = parseRequest_ (unUri explorerUri) & setRequestPath (Data.pack path) + debugM ("Request is: " ++ show request) + response <- httpJSON request + debugM ("Response is: " ++ show response) + let parsedResponse = getResponseBody response - debugM ("Response is: " ++ show parsedResponse) + debugM ("ParsedResponse is: " ++ show parsedResponse) pure parsedResponse From 8fa2cbad9e4ffa9a3d1153577667d179a8af4528 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Fri, 22 Sep 2023 11:37:34 +0200 Subject: [PATCH 47/50] add selectUtxosStrictLbsp --- quickblue/src/Explorer/Service.hs | 16 ++++++----- wallet-api/src/WalletAPI/Utxos.hs | 46 +++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+), 7 deletions(-) diff --git a/quickblue/src/Explorer/Service.hs b/quickblue/src/Explorer/Service.hs index 7465088a..5e2a35fa 100644 --- a/quickblue/src/Explorer/Service.hs +++ b/quickblue/src/Explorer/Service.hs @@ -17,6 +17,7 @@ import Prelude hiding (Ordering) import System.Logging.Hlog (Logging (Logging, debugM, infoM), MakeLogging (MakeLogging, forComponent)) import Common.String.Formatting (toLower) import Control.Exception (handle, SomeException) +import RIO (MonadThrow) data Explorer f = Explorer { getOutput :: TxOutRef -> f (Maybe FullTxOut) @@ -26,7 +27,7 @@ data Explorer f = Explorer , getTxs :: Paging -> Ordering -> f (Items FullTx) } -mkExplorer :: (Monad i, MonadIO f) => MakeLogging i f -> ExplorerConfig -> i (Explorer f) +mkExplorer :: (Monad i, MonadIO f, MonadThrow f) => MakeLogging i f -> ExplorerConfig -> i (Explorer f) mkExplorer MakeLogging{..} conf = do logging <- forComponent "explorer" pure $ Explorer @@ -37,27 +38,28 @@ mkExplorer MakeLogging{..} conf = do , getTxs = getTxs' logging conf } -getOutput' :: MonadIO f => Logging f -> ExplorerConfig -> TxOutRef -> f (Maybe FullTxOut) +getOutput' :: (MonadIO f, MonadThrow f) => Logging f -> ExplorerConfig -> TxOutRef -> f (Maybe FullTxOut) getOutput' logging conf@ExplorerConfig{..} ref = mkSafeGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/" ++ renderTxOutRef ref -getUnspentOutputs' :: MonadIO f => Logging f -> ExplorerConfig -> Gix -> Limit -> Ordering -> f (Items FullTxOut) +getUnspentOutputs' :: (MonadIO f, MonadThrow f) => Logging f -> ExplorerConfig -> Gix -> Limit -> Ordering -> f (Items FullTxOut) getUnspentOutputs' logging conf@ExplorerConfig{..} minIndex limit ordering = mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/unspent/indexed?minIndex=" ++ show minIndex ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering -getUnspentOutputsByPCred' :: MonadIO f => Logging f -> ExplorerConfig -> PaymentCred -> Paging -> f (Items FullTxOut) +getUnspentOutputsByPCred' :: (MonadIO f, MonadThrow f) => Logging f -> ExplorerConfig -> PaymentCred -> Paging -> f (Items FullTxOut) getUnspentOutputsByPCred' logging conf@ExplorerConfig{..} pcred Paging{..} = mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/outputs/unspent/byPaymentCred/" ++ T.unpack (unPaymentCred pcred) ++ "/?offset=" ++ show offset ++ "&limit=" ++ show limit -getSystemEnv' :: MonadIO f => Logging f -> ExplorerConfig -> f SystemEnv +getSystemEnv' :: (MonadIO f, MonadThrow f) => Logging f -> ExplorerConfig -> f SystemEnv getSystemEnv' logging conf@ExplorerConfig{..} = mkGetRequest logging conf ("/cardano/v1/" ++ toLower (show network) ++ "/networkParams") -getTxs' :: MonadIO f => Logging f -> ExplorerConfig -> Paging -> Ordering -> f (Items FullTx) +getTxs' :: (MonadIO f, MonadThrow f) => Logging f -> ExplorerConfig -> Paging -> Ordering -> f (Items FullTx) getTxs' logging conf@ExplorerConfig{..} Paging{..} ordering = mkGetRequest logging conf $ "/cardano/" ++ toLower (show network) ++ "/v1/transactions/?offset=" ++ show offset ++ "&limit=" ++ show limit ++ "&ordering=" ++ show ordering -mkGetRequest :: (MonadIO f, FromJSON a, Show a) => Logging f -> ExplorerConfig -> String -> f a +mkGetRequest :: (MonadIO f, FromJSON a, Show a, MonadThrow f) => Logging f -> ExplorerConfig -> String -> f a mkGetRequest Logging{..} ExplorerConfig{..} path = do + let request = parseRequest_ (unUri explorerUri) & setRequestPath (Data.pack path) debugM ("Request is: " ++ show request) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index cd97c2f6..a2165ede 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -39,6 +39,7 @@ data WalletOutputs f = WalletOutputs { selectUtxos :: Value -> f (Maybe (Set.Set FullTxOut)) -- Assets other than present in the given minimal Value are not allowed. , selectUtxosStrict :: Value -> f (Maybe (Set.Set FullTxOut)) + , selectUtxosStrictLbsp :: Value -> f (Maybe (Set.Set FullTxOut)) } mkPersistentWalletOutputs :: @@ -56,6 +57,7 @@ mkPersistentWalletOutputs fToI mkLogging@MakeLogging{..} cfg explorer vaultF = d pure $ WalletOutputs { selectUtxos = selectUtxos'' logging explorer ustore pkh False , selectUtxosStrict = selectUtxos'' logging explorer ustore pkh True + , selectUtxosStrictLbsp = selectUtxosLbsp'' logging explorer ustore pkh 0 True } filterSpentedUtxos :: (Monad f) => UtxoStore f -> Explorer f -> f () @@ -75,6 +77,7 @@ mkWalletOutputs mkLogging@MakeLogging{..} explorer pkh = do pure $ WalletOutputs { selectUtxos = selectUtxos'' logging explorer ustore pkh False , selectUtxosStrict = selectUtxos'' logging explorer ustore pkh True + , selectUtxosStrictLbsp = selectUtxosLbsp'' logging explorer ustore pkh 0 True } mkWalletOutputs' :: forall i f. (MonadIO i, MonadIO f, MonadMask f) => (f ~> i) -> MakeLogging i f -> Explorer f -> Vault f -> i (WalletOutputs f) @@ -124,6 +127,49 @@ selectUtxos'' logging explorer ustore@UtxoStore{..} pkh strict requiredValue = d Nothing -> fetchUtxos 0 batchSize >> selectUtxos'' logging explorer ustore pkh strict requiredValue where batchSize = 400 +selectUtxosLbsp'' :: (MonadIO f, MonadMask f) => Logging f -> Explorer f -> UtxoStore f -> Hash PaymentKey -> Integer -> Bool -> Value -> f (Maybe (Set.Set FullTxOut)) +selectUtxosLbsp'' logging explorer ustore@UtxoStore{..} pkh attempt strict requiredValue = do + let + fetchUtxos offset limit = do + let + paging = Explorer.Paging offset limit + mkPCred = Explorer.PaymentCred . T.decodeUtf8 . convertToBase Base16 . serialiseToRawBytes + utxoBatch <- getUnspentOutputsByPCredWithRetry logging explorer (mkPCred pkh) paging + putUtxos (Set.fromList $ Explorer.items utxoBatch <&> Explorer.toCardanoTx) + let entriesLeft = Explorer.total utxoBatch - (offset + limit) + + if entriesLeft > 0 + then pure () -- fetchUtxos (offset + limit) limit + else pure () + + extractAssets v = Set.fromList (flattenValue v <&> (\(cs, tn, _) -> (cs, tn))) + requiredAssets = extractAssets requiredValue + + collect :: [FullTxOut] -> Value -> [FullTxOut] -> Maybe [FullTxOut] + collect acc valueAcc outs = + case outs of + fout@FullTxOut{..} : tl | valueAcc `lt` requiredValue -> + if satisfies + then collect (fout : acc) (fullTxOutValue <> valueAcc) tl + else collect acc valueAcc tl -- current output doesn't contain the required asset at all, so skipping it + where + assets = extractAssets fullTxOutValue + containsTargetAsset = not $ Set.null $ Set.intersection assets requiredAssets + containsOtherAssets = not $ Set.null $ Set.difference assets requiredAssets + satisfies = (containsTargetAsset && not strict) || (containsTargetAsset && not containsOtherAssets) + [] | valueAcc `lt` requiredValue -> + Nothing + _ -> + Just acc + + filterSpentedUtxos ustore explorer + utxos <- getUtxos + if attempt == 1 then pure Nothing + else case collect [] mempty (Set.elems utxos) of + Just outs -> pure $ Just $ Set.fromList outs + Nothing -> fetchUtxos 0 batchSize >> selectUtxosLbsp'' logging explorer ustore pkh (attempt + 1) strict requiredValue + where batchSize = 400 + getUnspentOutputsByPCredWithRetry :: (MonadIO f, MonadMask f) => Logging f -> Explorer f -> PaymentCred -> Paging -> f (Items Explorer.FullTxOut) getUnspentOutputsByPCredWithRetry Logging{..} Explorer{..} cred paging = do let From f50c30a1fa11bab9dd338f3aecba1c1a5b7e392b Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Mon, 25 Sep 2023 14:39:38 +0200 Subject: [PATCH 48/50] change logic of selectUtxosLbsp --- wallet-api/src/WalletAPI/Utxos.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index a2165ede..c742ec1a 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -163,6 +163,7 @@ selectUtxosLbsp'' logging explorer ustore@UtxoStore{..} pkh attempt strict requi Just acc filterSpentedUtxos ustore explorer + fetchUtxos 0 400 utxos <- getUtxos if attempt == 1 then pure Nothing else case collect [] mempty (Set.elems utxos) of From 39fe9de8a613a8cfec07fd6bea235248577686ed Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Thu, 28 Sep 2023 15:15:37 +0200 Subject: [PATCH 49/50] remove condition of incorrect pool parsing --- dex-core/src/ErgoDex/Amm/Orders.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/Orders.hs b/dex-core/src/ErgoDex/Amm/Orders.hs index e0a08940..8423585b 100644 --- a/dex-core/src/ErgoDex/Amm/Orders.hs +++ b/dex-core/src/ErgoDex/Amm/Orders.hs @@ -50,7 +50,7 @@ instance FromLedger Swap where if isAda swapBase then baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen else baseAmount - when (unAmount baseIn < minBase) Nothing + -- when (unAmount baseIn < minBase) Nothing Just $ OnChain fout Swap { swapPoolId = PoolId $ Coin poolNft , swapBaseIn = Amount baseAmount @@ -80,7 +80,7 @@ instance FromLedger Deposit where (Just DepositConfig{..}) -> do let adaIn = Ada.getLovelace $ Ada.fromValue fullTxOutValue adaDeclared = exFee + collateralAda - when (adaIn < adaDeclared) Nothing + -- when (adaIn < adaDeclared) Nothing case extractPairValue fullTxOutValue of [assetX, assetY] -> Just $ OnChain fout Deposit From ea1fd6c3e8a9104321d3e3a667d4a5e6f81a6602 Mon Sep 17 00:00:00 2001 From: Bromel777 Date: Tue, 31 Oct 2023 11:29:57 +0100 Subject: [PATCH 50/50] add swap debug --- dex-core/src/ErgoDex/Amm/Orders.hs | 14 +++++- dex-core/src/ErgoDex/Amm/Pool.hs | 9 +++- dex-core/test/Main.hs | 13 +++--- dex-core/test/Spec/Pool.hs | 59 ++++++++++++++++++------- submit-api/src/SubmitAPI/Service.hs | 3 ++ submit-api/test/Main.hs | 68 +++++++++++++++++++++++------ wallet-api/src/WalletAPI/Utxos.hs | 2 +- wallet-api/src/WalletAPI/Vault.hs | 3 ++ 8 files changed, 130 insertions(+), 41 deletions(-) diff --git a/dex-core/src/ErgoDex/Amm/Orders.hs b/dex-core/src/ErgoDex/Amm/Orders.hs index 8423585b..7e6b9338 100644 --- a/dex-core/src/ErgoDex/Amm/Orders.hs +++ b/dex-core/src/ErgoDex/Amm/Orders.hs @@ -25,6 +25,7 @@ import ErgoDex.Contracts.Types import ErgoDex.Contracts.Proxy.Swap import ErgoDex.Contracts.Proxy.Deposit import ErgoDex.Contracts.Proxy.Redeem +import Debug.Trace data Swap = Swap { swapPoolId :: PoolId @@ -40,7 +41,7 @@ data Swap = Swap -- 10 000 000 000 000 000 instance FromLedger Swap where - parseFromLedger fout@FullTxOut{fullTxOutDatum=(KnownDatum (Datum d)), ..} = + parseFromLedger fout@FullTxOut{fullTxOutDatum=(KnownDatum (Datum d)), fullTxOutRef, ..} = case fromBuiltinData d of (Just SwapConfig{..}) -> do let @@ -50,7 +51,16 @@ instance FromLedger Swap where if isAda swapBase then baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen else baseAmount - -- when (unAmount baseIn < minBase) Nothing + traceM $ "Found swap config for " ++ show (PoolId $ Coin poolNft) + traceM $ "baseIn " ++ show baseIn + traceM $ "baseAmount" ++ show baseAmount + traceM $ "minQuoteAmount" ++ show minQuoteAmount + traceM $ "exFeePerTokenNum" ++ show exFeePerTokenNum + traceM $ "exFeePerTokenDen" ++ show exFeePerTokenDen + traceM $ "divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen" ++ show (divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen) + traceM $ "minBase " ++ show minBase + traceM $ "(unAmount baseIn < minBase) " ++ show (unAmount baseIn < minBase) + when (unAmount baseIn < minBase) Nothing Just $ OnChain fout Swap { swapPoolId = PoolId $ Coin poolNft , swapBaseIn = Amount baseAmount diff --git a/dex-core/src/ErgoDex/Amm/Pool.hs b/dex-core/src/ErgoDex/Amm/Pool.hs index 857fc9bc..ac68a92c 100644 --- a/dex-core/src/ErgoDex/Amm/Pool.hs +++ b/dex-core/src/ErgoDex/Amm/Pool.hs @@ -15,6 +15,7 @@ import Plutus.V1.Ledger.Api (StakingCredential(..)) import PlutusTx.Numeric (AdditiveMonoid(zero)) import Ledger.Ada (lovelaceValueOf) import Plutus.Script.Utils.V2.Address (mkValidatorAddress) +import Debug.Trace import CardanoTx.Models ( FullTxOut(FullTxOut, fullTxOutDatum, fullTxOutValue, @@ -30,8 +31,12 @@ import ErgoDex.Validators import qualified ErgoDex.Contracts.Typed as S import ErgoDex.Contracts.Types import qualified ErgoDex.Contracts.Proxy.Order as W -import ErgoDex.Contracts.Pool +import ErgoDex.Contracts.Pool + ( PoolConfig(PoolConfig, lqBound, stakeAdminPolicy, poolFeeNum, + poolLq, poolY, poolX, poolNft), + maxLqCapAmount ) import ErgoDex.Amm.Constants (minSafeOutputAmount) +import Debug.Trace newtype PoolId = PoolId { unPoolId :: Coin Nft } deriving (Show, Eq, Generic) @@ -201,7 +206,7 @@ applyRedeem poolValidator p@Pool{..} burnedLq = nextPoolOut = toLedger poolValidator nextPool applySwap :: PoolValidator ver -> Pool -> AssetAmount Base -> Predicted Pool -applySwap poolValidator p@Pool{..} base = +applySwap poolValidator p@Pool{..} base = do Predicted nextPoolOut nextPool where xy = unCoin (getAsset base) == unCoin poolCoinX diff --git a/dex-core/test/Main.hs b/dex-core/test/Main.hs index a2c20c93..32e26eac 100644 --- a/dex-core/test/Main.hs +++ b/dex-core/test/Main.hs @@ -12,10 +12,11 @@ main = do defaultMain tests tests = testGroup "DexCore" - [ PS.toFromLedgerPoolTests - , PS.checkDeposit - , PS.checkRedeem - , PS.checkSwap - , PS.initialLiquidityTests - , PS.initPoolTests + [ + -- PS.toFromLedgerPoolTests + -- , PS.checkDeposit + -- , PS.checkRedeem + PS.checkSwap + -- , PS.initialLiquidityTests + -- , PS.initPoolTests ] diff --git a/dex-core/test/Spec/Pool.hs b/dex-core/test/Spec/Pool.hs index 2139f70f..3b9bf38c 100644 --- a/dex-core/test/Spec/Pool.hs +++ b/dex-core/test/Spec/Pool.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Spec.Pool ( initialLiquidityTests @@ -36,6 +37,9 @@ import ErgoDex.Validators import ErgoDex.Amm.PoolSetup (burnLqInitial) import ErgoDex.Class (ToLedger(toLedger), FromLedger(parseFromLedger)) import ErgoDex.Amm.Constants (minSafeOutputAmount) +import qualified ErgoDex.Contracts.Pool as Pool +import Debug.Trace +import ErgoDex.Plutus (adaAssetClass) mkTokenName :: BS.ByteString -> TokenName mkTokenName = TokenName . BuiltinByteString @@ -50,7 +54,7 @@ poolNft :: Coin Nft poolNft = Coin $ mkAssetClass "nft" "pool_nft" poolX :: Coin X -poolX = Coin $ mkAssetClass "x" "pool_x" +poolX = Coin adaAssetClass poolY :: Coin Y poolY = Coin $ mkAssetClass "y" "pool_y" @@ -59,7 +63,7 @@ poolLq :: Coin Liquidity poolLq = Coin $ mkAssetClass "lq" "pool_lq" baseX :: Coin Base -baseX = Coin $ mkAssetClass "x" "pool_x" +baseX = Coin adaAssetClass baseY :: Coin Base baseY = Coin $ mkAssetClass "y" "pool_y" @@ -70,7 +74,7 @@ quoteX = Coin $ mkAssetClass "x" "pool_x" quoteY :: Coin Quote quoteY = Coin $ mkAssetClass "y" "pool_y" -poolFeeNum = 995 +poolFeeNum = 997 initialLiquidityTests = testGroup "InitialLiquidity" [ testCase "initial_liquidity_exact" $ @@ -82,11 +86,11 @@ initialLiquidityTests = testGroup "InitialLiquidity" poolConf = S.PoolConfig poolNft poolX poolY poolLq poolFeeNum -sufficientInitDepositX = Amount 800 +sufficientInitDepositX = Amount 2116188887 -insufficientInitDepositX = Amount 500 +insufficientInitDepositX = Amount 36866825013 -initDepositY = Amount 2000 +initDepositY = Amount 36866825013 releasedLq = Amount 265 @@ -197,21 +201,44 @@ swapYPP = nativePool } checkSwap = testGroup "SwapCheck" - [ testCase "correct_output_amount_x_base" $ - outputAmount nativePool (assetAmountCoinOf baseX 20) @=? assetAmountCoinOf quoteY 48 - , testCase "correct_output_amount_y_base" $ - outputAmount nativePool (assetAmountCoinOf baseY 80) @=? assetAmountCoinOf quoteX 30 - , HH.testProperty "correct_apply_swap_x_base" correctApplySwapXBase - , HH.testProperty "correct_apply_swap_y_base" correctApplySwapYBase + [ + -- testCase "correct_output_amount_x_base" $ + -- outputAmount nativePool (assetAmountCoinOf baseX 20) @=? assetAmountCoinOf quoteY 48 + -- , testCase "correct_output_amount_y_base" $ + -- outputAmount nativePool (assetAmountCoinOf baseY 80) @=? assetAmountCoinOf quoteX 30 + HH.testProperty "correct_apply_swap_x_base" correctApplySwapXBase + --, HH.testProperty "correct_apply_swap_y_base" correctApplySwapYBase ] correctApplySwapXBase :: Property -correctApplySwapXBase = property $ do +correctApplySwapXBase = withTests 1 $ property $ do pv <- fetchPoolValidatorV1 let - swap = applySwap pv nativePool (assetAmountCoinOf baseX 20) - swapXPPToLedger = toLedger pv swapXPP - swap === Predicted swapXPPToLedger swapXPP + p = nativePool + xy = unCoin (getAsset (assetAmountCoinOf baseX 100000000)) == unCoin (poolCoinX p) + baseAmount = unAmount $ getAmount (assetAmountCoinOf baseX 100000000) + poolReservesX' = unAmount (poolReservesX p) + poolReservesY' = unAmount (poolReservesY p) + quoteAmount = assetAmountRawValue (outputAmount p (assetAmountCoinOf baseX 100000000)) + + nextPool = + if xy then p + { poolReservesX = Amount $ poolReservesX' + baseAmount + , poolReservesY = Amount $ poolReservesY' - quoteAmount + } + else p + { poolReservesX = Amount $ poolReservesX' - quoteAmount + , poolReservesY = Amount $ poolReservesY' + baseAmount + } + swap@(Predicted _ newPool) = applySwap pv nativePool (assetAmountCoinOf baseX 100000000) + -- swapXPPToLedger = toLedger pv swapXPP + traceM $ "reserves_x before swap:" ++ show (poolReservesX p) + traceM $ "reserves_y before swap:" ++ show (poolReservesY p) + traceM $ "quote amount:" ++ show quoteAmount + traceM $ "reserves_x after swap:" ++ show (poolReservesX newPool) + traceM $ "reserves_y after swap:" ++ show (poolReservesY newPool) + 1 === 1 + --swap === Predicted swapXPPToLedger swapXPP correctApplySwapYBase :: Property correctApplySwapYBase = property $ do diff --git a/submit-api/src/SubmitAPI/Service.hs b/submit-api/src/SubmitAPI/Service.hs index bdf75c33..3a8c80f2 100644 --- a/submit-api/src/SubmitAPI/Service.hs +++ b/submit-api/src/SubmitAPI/Service.hs @@ -29,6 +29,7 @@ import Plutus.V1.Ledger.Api (adaToken) import Ledger.Value (assetClassValueOf) import System.Logging.Hlog import Cardano.Api.SerialiseTextEnvelope +import Debug.Trace data Transactions f era = Transactions { estimateTxFee :: Set.Set Sdk.FullCollateralTxIn -> Sdk.TxCandidate -> f C.Lovelace @@ -95,6 +96,8 @@ finalizeTx' CardanoNetwork{..} network refScriptsMap utxos Vault{..} conf@TxAsse where getPkh Sdk.FullTxOut{fullTxOutAddress=P.Address (P.PubKeyCredential pkh) _} = [pkh] getPkh _ = [] + Debug.Trace.traceM $ "Inputs: " ++ show allInputs + Debug.Trace.traceM $ "Pkhs to sign: " ++ show signatories signers <- mapM (\pkh -> getSigningKey pkh >>= maybe (throwM $ SignerNotFound pkh) pure) signatories pure $ Internal.signTx txb signers diff --git a/submit-api/test/Main.hs b/submit-api/test/Main.hs index e9ca3f5a..e1d84035 100644 --- a/submit-api/test/Main.hs +++ b/submit-api/test/Main.hs @@ -42,7 +42,7 @@ import Cardano.Api.Shelley ( fromPlutusData ) import WalletAPI.TrustStore (importTrustStoreFromCardano, SecretFile (SecretFile), KeyPass (KeyPass), mkTrustStore) import qualified Ledger as PV2 import CardanoTx.Address (readShellyAddress) -import WalletAPI.Vault (Vault (getPaymentKeyHash), mkVault) +import WalletAPI.Vault (Vault (getPaymentKeyHash, getSigningKey), mkVault) import qualified Explorer.Types as Explorer import qualified Plutus.V1.Ledger.Api as P import qualified Plutus.V1.Ledger.Bytes as Data @@ -52,14 +52,14 @@ import Ledger.Ada (lovelaceValueOf) import Ledger.Value (assetClassValue) import qualified PlutusTx.AssocMap as Map import qualified Plutus.V1.Ledger.Interval as Interval -import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction (Refund)) +import ErgoDex.Contracts.Proxy.Order (OrderRedeemer(OrderRedeemer), OrderAction (..)) import Control.Monad.IO.Class (MonadIO(liftIO)) import RIO (lift, (&)) import Control.Monad.Trans.Except (runExceptT) import Common.Throw.Combinators (throwEither) import ErgoDex.Contracts.Proxy.Swap (SwapConfig (..)) import PlutusTx.Prelude (divide) -import TestDatum (LBSPDatum(LBSPDatum)) +-- import TestDatum (LBSPDatum(LBSPDatum)) data TokenInfo = TokenInfo { curSymbol :: String @@ -168,11 +168,24 @@ eraseLeft (Right l) = Right l eraseLeft (Left _) = Left () test123 = do - - importTrustStoreFromCardano @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/lbspSecret.json") "/home/bromel/projects/cardano-dex-sdk-haskell/secret.skey" (KeyPass "lbsp") + + -- importTrustStoreFromCardano @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/lbspSecret.json") "/home/bromel/projects/cardano-dex-sdk-haskell/secret.skey" (KeyPass "Wy4ECCEj5V7mfCl5") + + let + trustStore = mkTrustStore @_ @C.PaymentKey C.AsPaymentKey (SecretFile "/home/bromel/projects/cardano-dex-sdk-haskell/test.json") + vault = mkVault trustStore $ (KeyPass "lbsp") :: Vault IO + + test123 <- getPaymentKeyHash vault + + print $ "keyHash: " ++ show test123 print $ "test" - print $ readShellyAddress "addr1wyqnt3mp3fc75mseaw74j2zxz4l3rj8uaujp20cuz7jva6q2crsut" + print $ readShellyAddress "addr1zy6r74xk4haj26c7jpq6w25t2xt8qzr9wr2kz805n8re02ktxjcad958hxmsqdvrvx8h6exaauck5qvxcskptdhe2u2swxmc3t" + print $ readShellyAddress "addr1qykdlv8vv7cg4ehw20w06q5st63xf2cqw8m9wmcrjdj248wtxjcad958hxmsqdvrvx8h6exaauck5qvxcskptdhe2u2s682lku" + -- print $ readShellyAddress "addr1x8nz307k3sr60gu0e47cmajssy4fmld7u493a4xztjrll0aj764lvrxdayh2ux30fl0ktuh27csgmpevdu89jlxppvrswgxsta" + + print $ "===============" + let stablePkh :: P.PubKeyHash @@ -251,19 +264,46 @@ test123 = do -- print $ readShellyAddress "addr1vxkafxhgw4kp7ahxnmu87kv23e4drml50h4tqu7vj7ddzvs03pqaf" let - testData = "d8799fd8799f4040ffd8799f581c5d16cc1a177b5d9ba9cfa9793b07e60f1fb70fea1f8aef064415d11443494147ffd8799f581cb992582b95a3ee20cb4025699808c83caaefa7bae9387b72ba2c57c34b4941475f4144415f4e4654ff1903e51b003ec43ba36ca2901b8000000000000000581cf7d32615876de5429e8f4b596642977912d8c0638fccbe15784cec33d8799f581c75579cbeb4029bebe2a9bdeb7da16bd65bf8bfbe387f368464813cf2ff1a6f4312a61b00000001fa0fc783ff" + testData = "d8799fd8799f581cdda5fdb1002f7389b33e036b6afee82a8189becb6cba852e8b79b4fb480014df1047454e53ffd8799f4040ffd8799f581cce809b9081e15b890e6fad395e7581b82ff3769224df72573821ae4d520014efbfbd1047454e535f4144415f4e4654ff1903e51a002625a01b000000024408757b581ce3a0254c00994f731550f81239f12a60c9fd3ce9b9b191543152ec22d8799f581cb1bec305ddc80189dac8b628ee0adfbe5245c53b84e678ed7ec23d75ff1a0168cc891b000000024408757bff" plutusDataE = (\bs -> deserialise (LBS.fromStrict bs) :: Data) `fmap` (Hex.decode . T.encodeUtf8 $ testData) poolConfig = (\d -> (fromData d) :: Maybe SwapConfig) `fmap` plutusDataE - SwapConfig{..} = unsafeFromMaybe . unsafeFromEither $ poolConfig + swap@SwapConfig{..} = unsafeFromMaybe . unsafeFromEither $ poolConfig + + + testDataP = "d8799fd8799f581cce809b9081e15b890e6fad395e7581b82ff3769224df72573821ae4d520014efbfbd1047454e535f4144415f4e4654ffd8799f4040ffd8799f581cdda5fdb1002f7389b33e036b6afee82a8189becb6cba852e8b79b4fb4a0014efbfbd1047454e53ffd8799f581c59e5f3deabe0bb52d8a1619595ac8096ecd073ffc37ca4bb0fa88942510014efbfbd1047454e535f4144415f4c51ff1903e58000ff" + plutusDataEP = (\bs -> deserialise (LBS.fromStrict bs) :: Data) `fmap` (Hex.decode . T.encodeUtf8 $ testDataP) + poolConfigP = (\d -> (fromData d) :: Maybe PoolConfig) `fmap` plutusDataEP + pool = unsafeFromMaybe . unsafeFromEither $ poolConfigP + test = baseAmount + divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen + minFee = divide (minQuoteAmount * exFeePerTokenNum) exFeePerTokenDen - lbspDatum = LBSPDatum [[stablePkh, stablePkh], [stablePkh], [stablePkh, stablePkh]] + -- lbspDatum = LBSPDatum [[stablePkh, stablePkh], [stablePkh], [stablePkh, stablePkh]] - print ("lbsp " ++ show ((Json.encode - . scriptDataToJson ScriptDataJsonDetailedSchema - . fromPlutusData - . toData - $ lbspDatum ))) + swapRedeemer = toData $ OrderRedeemer 1 0 0 Refund + poolRedeemer = toData $ PoolRedeemer Destroy 0 + + -- testA = unAmount baseIn < test + + print $ "pool Swap redeemer:" ++ T.unpack ((T.decodeUtf8 . Hex.encode $ (LBS.toStrict $ serialise $ poolRedeemer))) + + print $ "Swap cfg: " ++ show (Prelude.snd . unAssetClass $ base) + + print $ "Pool cfg: " ++ show (Prelude.snd . unAssetClass $ (poolY pool)) + + print $ "equal x:" ++ show ((Prelude.snd . unAssetClass $ base) == (Prelude.snd . unAssetClass $ (poolY pool))) + + print $ "test: " ++ (show test) + print $ "baseIn: " ++ (show 1005500000) + + print $ "base amount: " ++ show baseAmount + print $ "Min fee: " ++ show minFee + + -- print ("lbsp " ++ show ((Json.encode + -- . scriptDataToJson ScriptDataJsonDetailedSchema + -- . fromPlutusData + -- . toData + -- $ lbspDatum ))) pool <- poolValidator print (PV2.mkValidatorAddress pool) diff --git a/wallet-api/src/WalletAPI/Utxos.hs b/wallet-api/src/WalletAPI/Utxos.hs index c742ec1a..8e1991b0 100644 --- a/wallet-api/src/WalletAPI/Utxos.hs +++ b/wallet-api/src/WalletAPI/Utxos.hs @@ -175,5 +175,5 @@ getUnspentOutputsByPCredWithRetry :: (MonadIO f, MonadMask f) => Logging f -> Ex getUnspentOutputsByPCredWithRetry Logging{..} Explorer{..} cred paging = do let -- backoff = constantDelay 1000000 - limitedBackoff = exponentialBackoff 50000 <> limitRetries 5 + limitedBackoff = constantDelay 50000 <> limitRetries 5 recoverAll limitedBackoff (\rs -> infoM ("RetryStatus for getUnspentOutputsByPCredWithRetry " ++ show rs) >> getUnspentOutputsByPCred cred paging) \ No newline at end of file diff --git a/wallet-api/src/WalletAPI/Vault.hs b/wallet-api/src/WalletAPI/Vault.hs index 06281cbd..87d06643 100644 --- a/wallet-api/src/WalletAPI/Vault.hs +++ b/wallet-api/src/WalletAPI/Vault.hs @@ -7,6 +7,7 @@ import Ledger (PubKeyHash(..)) import qualified Cardano.Api as C import Cardano.Api.Shelley import Algebra.Natural +import Debug.Trace import WalletAPI.TrustStore (TrustStore(TrustStore, readSK, readVK), KeyPass) @@ -37,6 +38,8 @@ getSigningKey' TrustStore{readSK} pass pkh = do sk <- readSK pass <&> WitnessPaymentKey let vk = extractVK (toShelleySigningKey sk) pkh' = PubKeyHash $ PlutusTx.toBuiltin $ C.serialiseToRawBytes $ C.verificationKeyHash vk + Debug.Trace.traceM $ "Pkh in storage:" ++ show pkh' + Debug.Trace.traceM $ "Pkh to check:" ++ show pkh unless (pkh == pkh') (throwM VaultCorrupted) pure sk <&> Just