Skip to content

Commit 8a397e9

Browse files
IAmPara0xIAmPara0x
committed
fix bugs
1 parent c01f1cd commit 8a397e9

File tree

5 files changed

+110
-62
lines changed

5 files changed

+110
-62
lines changed

‎examples/debug/src/TimeDebugContract.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -155,7 +155,7 @@ splitUtxo = do
155155
ownPkh <- Contract.ownPaymentPubKeyHash
156156
let txc =
157157
Hask.mconcat $
158-
Hask.replicate 5 (Constraints.mustPayToPubKey ownPkh (adaValueOf 10))
158+
Hask.replicate 5 (Constraints.mustPayToPubKey ownPkh (adaValueOf 100))
159159
void $ submitTx txc
160160

161161
unlockWithTimeCheck :: Contract () EmptySchema Text Hask.String

‎src/BotPlutusInterface/Balance.hs‎

Lines changed: 24 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -212,7 +212,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
212212

213213
-- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
214214
txWithoutFees <-
215-
hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` 0
215+
newEitherT $ balanceTxStep @w minUtxos utxoIndex changeAddr $ tx `withFee` 0
216216

217217
exBudget <- newEitherT $ BodyBuilder.buildAndEstimateBudget @w pabConf privKeys txWithoutFees
218218

@@ -223,7 +223,7 @@ balanceTxIO' pabConf ownPkh unbalancedTx balanceTxType =
223223
lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
224224

225225
-- Rebalance the initial tx with the above fees
226-
balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees
226+
balancedTx <- newEitherT $ balanceTxStep @w minUtxos utxoIndex changeAddr $ tx `withFee` fees
227227

228228
if balancedTx == tx
229229
then pure (balancedTx, minUtxos)
@@ -288,15 +288,17 @@ calculateMinUtxos pabConf datums txOuts =
288288
zipWithM (fmap . (,)) txOuts <$> mapM (CardanoCLI.calculateMinUtxo @w pabConf datums) txOuts
289289

290290
balanceTxStep ::
291+
forall (w :: Type) (effs :: [Type -> Type]).
292+
Member (PABEffect w) effs =>
291293
[(TxOut, Integer)] ->
292294
Map TxOutRef TxOut ->
293295
Address ->
294296
Tx ->
295-
Either Text Tx
297+
Eff effs (Either Text Tx)
296298
balanceTxStep minUtxos utxos changeAddr tx =
297-
Right (addLovelaces minUtxos tx)
298-
>>= balanceTxIns utxos
299-
>>= handleNonAdaChange changeAddr utxos
299+
runEitherT $
300+
(newEitherT . balanceTxIns @w utxos) (addLovelaces minUtxos tx)
301+
>>= hoistEither . handleNonAdaChange changeAddr utxos
300302

301303
-- | Get change value of a transaction, taking inputs, outputs, mint and fees into account
302304
getChange :: Map TxOutRef TxOut -> Tx -> Value
@@ -385,17 +387,23 @@ addLovelaces minLovelaces tx =
385387
$ txOutputs tx
386388
in tx {txOutputs = lovelacesAdded}
387389

388-
balanceTxIns :: Map TxOutRef TxOut -> Tx -> Either Text Tx
390+
balanceTxIns ::
391+
forall (w :: Type) (effs :: [Type -> Type]).
392+
Member (PABEffect w) effs =>
393+
Map TxOutRef TxOut ->
394+
Tx ->
395+
Eff effs (Either Text Tx)
389396
balanceTxIns utxos tx = do
390-
let txOuts = Tx.txOutputs tx
391-
nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx
392-
minSpending =
393-
mconcat
394-
[ txFee tx
395-
, nonMintedValue
396-
]
397-
txIns <- selectTxIns (txInputs tx) utxos minSpending
398-
pure $ tx {txInputs = txIns <> txInputs tx}
397+
runEitherT $ do
398+
let txOuts = Tx.txOutputs tx
399+
nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx
400+
minSpending =
401+
mconcat
402+
[ txFee tx
403+
, nonMintedValue
404+
]
405+
txIns <- newEitherT $ selectTxIns @w (txInputs tx) utxos minSpending
406+
pure $ tx {txInputs = txIns <> txInputs tx}
399407

400408
-- | Set collateral or fail in case it's required but not available
401409
addTxCollaterals :: CollateralUtxo -> Tx -> Tx

‎src/BotPlutusInterface/CoinSelection.hs‎

Lines changed: 66 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,13 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
2+
13
module BotPlutusInterface.CoinSelection (valueToVec, valuesToVecs, selectTxIns) where
24

35
import Control.Lens (Cons, cons, ix, uncons, (^?))
6+
import Control.Monad.Freer (Eff, Member)
47

5-
import Data.Either.Combinators (maybeToRight)
8+
import Control.Monad.Trans.Class (lift)
9+
import Control.Monad.Trans.Either (hoistEither, runEitherT)
10+
import Data.Either.Combinators (isRight, maybeToRight)
611
import Data.Kind (Type)
712
import Data.Map (Map)
813
import Data.Map qualified as Map
@@ -20,44 +25,70 @@ import Plutus.V1.Ledger.Api (
2025
Credential (PubKeyCredential, ScriptCredential),
2126
)
2227

28+
import BotPlutusInterface.Effects (PABEffect, printBpiLog)
29+
import BotPlutusInterface.Types (LogLevel (Notice))
30+
31+
import Prettyprinter (pretty, (<+>))
2332
import Prelude
2433

2534
data Search = Greedy
2635
deriving stock (Show)
2736

28-
selectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn)
29-
selectTxIns originalTxIns utxosIndex outValue = do
30-
let txInsValue :: Value
31-
txInsValue =
32-
mconcat $ map txOutValue $ mapMaybe ((`Map.lookup` utxosIndex) . txInRef) $ Set.toList originalTxIns
37+
selectTxIns ::
38+
forall (w :: Type) (effs :: [Type -> Type]).
39+
Member (PABEffect w) effs =>
40+
Set TxIn ->
41+
Map TxOutRef TxOut ->
42+
Value ->
43+
Eff effs (Either Text (Set TxIn))
44+
selectTxIns originalTxIns utxosIndex outValue =
45+
runEitherT $ do
46+
lift $ printBpiLog @w Notice $ pretty (Map.toList utxosIndex)
47+
48+
let txInsValue :: Value
49+
txInsValue =
50+
mconcat $ map txOutValue $ mapMaybe ((`Map.lookup` utxosIndex) . txInRef) $ Set.toList originalTxIns
51+
52+
allAssetClasses :: Set AssetClass
53+
allAssetClasses =
54+
uniqueAssetClasses $ txInsValue : outValue : map (txOutValue . snd) (Map.toList utxosIndex)
3355

34-
allAssetClasses :: Set AssetClass
35-
allAssetClasses =
36-
uniqueAssetClasses $ txInsValue : outValue : map (txOutValue . snd) (Map.toList utxosIndex)
56+
txInRefs :: [TxOutRef]
57+
txInRefs = map txInRef $ Set.toList originalTxIns
3758

38-
txInRefs :: [TxOutRef]
39-
txInRefs = map txInRef $ Set.toList originalTxIns
59+
remainingUtxos :: [(TxOutRef, TxOut)]
60+
remainingUtxos =
61+
Map.toList $
62+
Map.filterWithKey
63+
(\k v -> k `notElem` txInRefs && isRight (txOutToTxIn (k, v)))
64+
utxosIndex
4065

41-
remainingUtxos :: [(TxOutRef, TxOut)]
42-
remainingUtxos = Map.toList $ Map.filterWithKey (\k _ -> k `notElem` txInRefs) utxosIndex
66+
lift $ printBpiLog @w Notice $ "\n\n Remaining UTxOs: " <+> pretty remainingUtxos <+> "\n\n"
4367

44-
txInsVec <-
45-
if Value.isZero txInsValue
46-
then Right $ zeroVec (toInteger $ length allAssetClasses)
47-
else valueToVec allAssetClasses txInsValue
68+
txInsVec <-
69+
hoistEither $
70+
if Value.isZero txInsValue
71+
then Right $ zeroVec (toInteger $ length allAssetClasses)
72+
else valueToVec allAssetClasses txInsValue
4873

49-
outVec <- valueToVec allAssetClasses outValue
74+
outVec <- hoistEither $ valueToVec allAssetClasses outValue
5075

51-
remainingUtxosVec <- mapM (valueToVec allAssetClasses . txOutValue . snd) remainingUtxos
76+
lift $ printBpiLog @w Notice $ "IsSufficient: " <+> pretty (isSufficient outVec txInsVec) <+> "\n\n"
5277

53-
selectedUtxosIdxs <- selectTxIns' Greedy (isSufficient outVec) outVec txInsVec remainingUtxosVec
78+
remainingUtxosVec <- hoistEither $ mapM (valueToVec allAssetClasses . txOutValue . snd) remainingUtxos
5479

55-
let selectedUtxos :: [(TxOutRef, TxOut)]
56-
selectedUtxos = mapMaybe (\idx -> remainingUtxos ^? ix (fromInteger idx)) selectedUtxosIdxs
80+
selectedUtxosIdxs <- hoistEither $ selectTxIns' Greedy (isSufficient outVec) outVec txInsVec remainingUtxosVec
5781

58-
selectedTxIns <- mapM txOutToTxIn selectedUtxos
82+
lift $ printBpiLog @w Notice $ "\n\n" <+> "Selected UTxOs Index: " <+> pretty selectedUtxosIdxs <+> "\n\n"
5983

60-
return $ originalTxIns <> Set.fromList selectedTxIns
84+
let selectedUtxos :: [(TxOutRef, TxOut)]
85+
selectedUtxos = mapMaybe (\idx -> remainingUtxos ^? ix (fromInteger idx)) selectedUtxosIdxs
86+
87+
selectedTxIns <- hoistEither $ mapM txOutToTxIn selectedUtxos
88+
89+
lift $ printBpiLog @w Notice $ "Selected TxIns: " <+> pretty selectedTxIns <+> "\n\n"
90+
91+
return $ originalTxIns <> Set.fromList selectedTxIns
6192
where
6293
isSufficient :: Vector Integer -> Vector Integer -> Bool
6394
isSufficient outVec = Vec.all (== True) . Vec.zipWith (<=) outVec
@@ -69,20 +100,20 @@ selectTxIns' ::
69100
Vector Integer ->
70101
[Vector Integer] ->
71102
Either Text [Integer]
72-
selectTxIns' Greedy stopSearch outVec txInsVec utxosVec =
73-
if null utxosVec
74-
then Right mempty
75-
else do
103+
selectTxIns' Greedy stopSearch outVec txInsVec utxosVec
104+
| null utxosVec || stopSearch txInsVec = Right mempty
105+
| otherwise =
106+
do
76107
utxosDist <- Vec.fromList . map (l2norm outVec) <$> mapM (addVec txInsVec) utxosVec
77108
let minIndex = toInteger $ Vec.minIndex utxosDist
78109

79-
(selectedUtxoVec, remainingUtxosVec) <- popN utxosVec minIndex
110+
(selectedUtxoVec, remainingUtxosVec) <- pop utxosVec minIndex
80111

81112
newTxInsVec <- addVec txInsVec selectedUtxoVec
82113

83-
case stopSearch newTxInsVec of
84-
True -> return [minIndex]
85-
False -> (minIndex :) <$> selectTxIns' Greedy stopSearch outVec newTxInsVec remainingUtxosVec
114+
if stopSearch newTxInsVec
115+
then return [minIndex]
116+
else (minIndex :) <$> selectTxIns' Greedy stopSearch outVec newTxInsVec remainingUtxosVec
86117

87118
l2norm :: Vector Integer -> Vector Integer -> Either Text Float
88119
l2norm v1 v2
@@ -144,15 +175,15 @@ txOutToTxIn (txOutRef, txOut) =
144175
PubKeyCredential _ -> Right $ pubKeyTxIn txOutRef
145176
ScriptCredential _ -> Left "Cannot covert a script output to TxIn"
146177

147-
popN ::
178+
pop ::
148179
forall (v :: Type -> Type) a.
149180
(Cons (v a) (v a) a a) =>
150181
v a ->
151182
Integer ->
152183
Either Text (a, v a)
153-
popN va idx = do
184+
pop va idx = do
154185
(a, va') <- maybeToRight "Error: Not able to uncons from empty structure." $ uncons va
155186

156187
if idx == 0
157188
then return (a, va')
158-
else popN va' (idx - 1) >>= (\(a', va'') -> return (a', cons a va''))
189+
else pop va' (idx - 1) >>= (\(a', va'') -> return (a', cons a va''))

‎test/Spec/BotPlutusInterface/Balance.hs‎

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,12 @@ module Spec.BotPlutusInterface.Balance (tests) where
22

33
import BotPlutusInterface.Balance (withFee)
44
import BotPlutusInterface.Balance qualified as Balance
5+
import BotPlutusInterface.Effects (PABEffect)
6+
import Data.Default (Default (def))
57
import Data.Map qualified as Map
68
import Data.Set qualified as Set
9+
import Data.Text (Text)
10+
import Data.Text qualified as Text
711
import Ledger qualified
812
import Ledger.Ada qualified as Ada
913
import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash))
@@ -12,8 +16,9 @@ import Ledger.CardanoWallet qualified as Wallet
1216
import Ledger.Crypto (PubKeyHash)
1317
import Ledger.Tx (Tx (..), TxIn (..), TxInType (..), TxOut (..), TxOutRef (..))
1418
import Ledger.Value qualified as Value
19+
import Spec.MockContract (runPABEffectPure)
1520
import Test.Tasty (TestTree, testGroup)
16-
import Test.Tasty.HUnit (Assertion, testCase, (@?=))
21+
import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
1722
import Prelude
1823

1924
{- | Tests for 'cardano-cli query utxo' result parsers
@@ -62,10 +67,11 @@ addUtxosForFees = do
6267
minUtxo = [(txout, 1_000_000)]
6368
utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
6469
ownAddr = addr1
65-
balancedTx =
66-
Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
70+
ebalancedTx = fst $ runPABEffectPure def $ Balance.balanceTxStep @[Text] @'[PABEffect [Text]] minUtxo utxoIndex ownAddr tx
6771

68-
txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])
72+
case ebalancedTx of
73+
Left e -> assertFailure (Text.unpack e)
74+
Right balanceTx -> txInputs <$> balanceTx @?= Right (Set.fromList [txIn1, txIn2])
6975

7076
addUtxosForNativeTokens :: Assertion
7177
addUtxosForNativeTokens = do
@@ -74,10 +80,11 @@ addUtxosForNativeTokens = do
7480
minUtxo = [(txout, 1_000_000)]
7581
utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4]
7682
ownAddr = addr1
77-
balancedTx =
78-
Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
83+
ebalancedTx = fst $ runPABEffectPure def $ Balance.balanceTxStep @[Text] @'[PABEffect [Text]] minUtxo utxoIndex ownAddr tx
7984

80-
txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4])
85+
case ebalancedTx of
86+
Left e -> assertFailure (Text.unpack e)
87+
Right balancedTx -> txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4])
8188

8289
addUtxosForChange :: Assertion
8390
addUtxosForChange = do
@@ -86,7 +93,8 @@ addUtxosForChange = do
8693
minUtxo = [(txout, 1_000_000)]
8794
utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
8895
ownAddr = addr1
89-
balancedTx =
90-
Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
96+
ebalancedTx = fst $ runPABEffectPure def $ Balance.balanceTxStep @[Text] @'[PABEffect [Text]] minUtxo utxoIndex ownAddr tx
9197

92-
txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])
98+
case ebalancedTx of
99+
Left e -> assertFailure (Text.unpack e)
100+
Right balancedTx -> txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])

‎test/Spec/MockContract.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ module Spec.MockContract (
3232
pkhAddr2,
3333
pkhAddr3,
3434
-- Test interpreter
35+
runPABEffectPure,
3536
runContractPure,
3637
runContractPure',
3738
MockContractState (..),

0 commit comments

Comments
 (0)