Skip to content
Permalink
Browse files

Compute max number of allowed inputs from tx max size

  • Loading branch information...
KtorZ committed Jul 12, 2019
1 parent 48b79f5 commit 58583f1688cb40f06f1652f37ac32cd1df3e0e8e
@@ -168,6 +168,8 @@ import Data.Text.Class
( toText )
import Data.Time.Clock
( diffTimeToPicoseconds, getCurrentTime )
import Data.Word
( Word16 )
import Fmt
( Buildable, blockListF, pretty, (+|), (+||), (|+), (||+) )

@@ -635,10 +637,9 @@ newWalletLayer tracer bp db nw tl = do
Transactions
---------------------------------------------------------------------------}

-- FIXME Compute the options based on the transaction's size / inputs
coinSelOpts :: CoinSelectionOptions (ErrValidateSelection t)
coinSelOpts = CoinSelectionOptions
{ maximumNumberOfInputs = 10
{ maximumNumberOfInputs = estimateMaxNumberOfInputs tl txMaxSize
, validate = validateSelection tl
}

@@ -34,7 +34,7 @@ import Crypto.Number.Generate
import Data.Vector.Mutable
( IOVector )
import Data.Word
( Word64 )
( Word64, Word8 )
import Fmt
( Buildable (..), blockListF, blockListF', listF, nameF )
import GHC.Generics
@@ -80,9 +80,11 @@ instance Buildable CoinSelection where

data CoinSelectionOptions e = CoinSelectionOptions
{ maximumNumberOfInputs
:: Word64
:: Word8 -> Word8
-- ^ Maximum number of inputs allowed for a given number of outputs
, validate
:: CoinSelection -> Either e ()
-- ^ Returns any backend-specific error regarding coin selection
} deriving (Generic)

data ErrCoinSelection e
@@ -46,8 +46,12 @@ largestFirst
-> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO)
largestFirst opt outs utxo = do
let descending = NE.toList . NE.sortBy (flip $ comparing coin)
let n = fromIntegral $ maximumNumberOfInputs opt
let nLargest = take n . L.sortBy (flip $ comparing (coin . snd)) . Map.toList . getUTxO
let nOuts = fromIntegral $ NE.length outs
let maxN = fromIntegral $ maximumNumberOfInputs opt (fromIntegral nOuts)
let nLargest = take maxN
. L.sortBy (flip $ comparing (coin . snd))
. Map.toList
. getUTxO
let guard = except . left ErrInvalidSelection . validate opt

case foldM atLeast (nLargest utxo, mempty) (descending outs) of
@@ -57,18 +61,17 @@ largestFirst opt outs utxo = do
let moneyRequested = sum $ (getCoin . coin) <$> (descending outs)
let utxoBalance = fromIntegral $ balance utxo
let nUtxo = fromIntegral $ L.length $ (Map.toList . getUTxO) utxo
let nOuts = fromIntegral $ NE.length outs

when (utxoBalance < moneyRequested)
$ throwE $ ErrNotEnoughMoney utxoBalance moneyRequested

when (nUtxo < nOuts)
$ throwE $ ErrUtxoNotEnoughFragmented nUtxo nOuts

when (fromIntegral n > nUtxo)
when (fromIntegral maxN > nUtxo)
$ throwE ErrInputsDepleted

throwE $ ErrMaximumInputsReached (fromIntegral n)
throwE $ ErrMaximumInputsReached (fromIntegral maxN)

-- Selecting coins to cover at least the specified value
-- The details of the algorithm are following:
@@ -116,12 +116,14 @@ random
-> ExceptT (ErrCoinSelection e) m (CoinSelection, UTxO)
random opt outs utxo = do
let descending = NE.toList . NE.sortBy (flip $ comparing coin)
let nOuts = fromIntegral $ NE.length outs
let maxN = fromIntegral $ maximumNumberOfInputs opt nOuts
randomMaybe <- lift $ runMaybeT $
foldM makeSelection (opt, utxo, []) (descending outs)
foldM makeSelection (maxN, utxo, []) (descending outs)
case randomMaybe of
Just (opt', utxo', res) -> do
Just (maxN', utxo', res) -> do
(_, sel, remUtxo) <- lift $
foldM improveTxOut (opt', mempty, utxo') (reverse res)
foldM improveTxOut (maxN', mempty, utxo') (reverse res)
guard sel $> (sel, remUtxo)
Nothing ->
largestFirst opt outs utxo
@@ -130,14 +132,14 @@ random opt outs utxo = do

-- | Perform a random selection on a given output, without improvement.
makeSelection
:: forall m e. MonadRandom m
=> (CoinSelectionOptions e, UTxO, [([(TxIn, TxOut)], TxOut)])
:: forall m. MonadRandom m
=> (Word64, UTxO, [([(TxIn, TxOut)], TxOut)])
-> TxOut
-> MaybeT m (CoinSelectionOptions e, UTxO, [([(TxIn, TxOut)], TxOut)])
makeSelection (CoinSelectionOptions maxNumInputs fn, utxo0, selection) txout = do
-> MaybeT m (Word64, UTxO, [([(TxIn, TxOut)], TxOut)])
makeSelection (maxNumInputs, utxo0, selection) txout = do
(inps, utxo1) <- coverRandomly ([], utxo0)
return
( CoinSelectionOptions (maxNumInputs - fromIntegral (L.length inps)) fn
( maxNumInputs - fromIntegral (L.length inps)
, utxo1
, (inps, txout) : selection
)
@@ -156,14 +158,14 @@ makeSelection (CoinSelectionOptions maxNumInputs fn, utxo0, selection) txout = d

-- | Perform an improvement to random selection on a given output.
improveTxOut
:: forall m e. MonadRandom m
=> (CoinSelectionOptions e, CoinSelection, UTxO)
:: forall m. MonadRandom m
=> (Word64, CoinSelection, UTxO)
-> ([(TxIn, TxOut)], TxOut)
-> m (CoinSelectionOptions e, CoinSelection, UTxO)
improveTxOut (opt0, selection, utxo0) (inps0, txout) = do
(opt, inps, utxo) <- improve (opt0, inps0, utxo0)
-> m (Word64, CoinSelection, UTxO)
improveTxOut (maxN0, selection, utxo0) (inps0, txout) = do
(maxN, inps, utxo) <- improve (maxN0, inps0, utxo0)
return
( opt
( maxN
, selection <> CoinSelection
{ inputs = inps
, outputs = [txout]
@@ -175,22 +177,22 @@ improveTxOut (opt0, selection, utxo0) (inps0, txout) = do
target = mkTargetRange txout

improve
:: forall m e. MonadRandom m
=> (CoinSelectionOptions e, [(TxIn, TxOut)], UTxO)
-> m (CoinSelectionOptions e, [(TxIn, TxOut)], UTxO)
improve (opt@(CoinSelectionOptions maxN fn), inps, utxo)
:: forall m. MonadRandom m
=> (Word64, [(TxIn, TxOut)], UTxO)
-> m (Word64, [(TxIn, TxOut)], UTxO)
improve (maxN, inps, utxo)
| maxN >= 1 && balance' inps < targetAim target = do
runMaybeT (pickRandomT utxo) >>= \case
Nothing ->
return (opt, inps, utxo)
return (maxN, inps, utxo)
Just (io, utxo') | isImprovement io inps -> do
let inps' = io : inps
let opt' = CoinSelectionOptions (maxN - 1) fn
improve (opt', inps', utxo')
let maxN' = maxN - 1
improve (maxN', inps', utxo')
Just _ ->
return (opt, inps, utxo)
return (maxN, inps, utxo)
| otherwise =
return (opt, inps, utxo)
return (maxN, inps, utxo)

isImprovement :: (TxIn, TxOut) -> [(TxIn, TxOut)] -> Bool
isImprovement io selected =
@@ -215,7 +215,7 @@ propDeterministic
:: CoinSelProp
-> Property
propDeterministic (CoinSelProp utxo txOuts) = do
let opts = CoinSelectionOptions 100 noValidation
let opts = CoinSelectionOptions (const 100) noValidation
let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts utxo
let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts utxo
resultOne === resultTwo
@@ -229,7 +229,7 @@ propAtLeast (CoinSelProp utxo txOuts) =
prop (CoinSelection inps _ _) =
L.length inps `shouldSatisfy` (>= NE.length txOuts)
selection = runIdentity $ runExceptT $
largestFirst (CoinSelectionOptions 100 noValidation) txOuts utxo
largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo

propInputDecreasingOrder
:: CoinSelProp
@@ -247,4 +247,4 @@ propInputDecreasingOrder (CoinSelProp utxo txOuts) =
(>= (getExtremumValue L.maximum utxo'))
getExtremumValue f = f . map (getCoin . coin . snd)
selection = runIdentity $ runExceptT $
largestFirst (CoinSelectionOptions 100 noValidation) txOuts utxo
largestFirst (CoinSelectionOptions (const 100) noValidation) txOuts utxo
@@ -250,9 +250,10 @@ propFragmentation drg (CoinSelProp utxo txOuts) = do
prop (CoinSelection inps1 _ _, CoinSelection inps2 _ _) =
L.length inps1 `shouldSatisfy` (>= L.length inps2)
(selection1,_) = withDRG drg
(runExceptT $ random (CoinSelectionOptions 100 noValidation) txOuts utxo)
(runExceptT $ random opt txOuts utxo)
selection2 = runIdentity $ runExceptT $
largestFirst (CoinSelectionOptions 100 noValidation) txOuts utxo
largestFirst opt txOuts utxo
opt = CoinSelectionOptions (const 100) noValidation

propErrors
:: SystemDRG
@@ -266,6 +267,7 @@ propErrors drg (CoinSelProp utxo txOuts) = do
prop (err1, err2) =
err1 === err2
(selection1,_) = withDRG drg
(runExceptT $ random (CoinSelectionOptions 1 noValidation) txOuts utxo)
(runExceptT $ random opt txOuts utxo)
selection2 = runIdentity $ runExceptT $
largestFirst (CoinSelectionOptions 1 noValidation) txOuts utxo
largestFirst opt txOuts utxo
opt = (CoinSelectionOptions (const 1) noValidation)
@@ -133,7 +133,7 @@ instance Buildable CoinSelProp where

-- | A fixture for testing the coin selection
data CoinSelectionFixture = CoinSelectionFixture
{ maxNumOfInputs :: Word64
{ maxNumOfInputs :: Word8
-- ^ Maximum number of inputs that can be selected
, validateSelection :: CoinSelection -> Either ErrValidation ()
-- ^ A extra validation function on the resulting selection
@@ -178,7 +178,7 @@ coinSelectionUnitTest run lbl expected (CoinSelectionFixture n fn utxoF outsF) =
(utxo,txOuts) <- setup
result <- runExceptT $ do
(CoinSelection inps outs chngs, _) <-
run (CoinSelectionOptions n fn) txOuts utxo
run (CoinSelectionOptions (const n) fn) txOuts utxo
return $ CoinSelectionResult
{ rsInputs = map (getCoin . coin . snd) inps
, rsChange = map getCoin chngs
@@ -521,7 +521,7 @@ genTxOut coins = do

genSelection :: NonEmpty TxOut -> Gen CoinSelection
genSelection outs = do
let opts = CS.CoinSelectionOptions 100 (const $ pure ())
let opts = CS.CoinSelectionOptions (const 100) (const $ pure ())
utxo <- vectorOf (NE.length outs * 3) arbitrary >>= genUTxO
case runIdentity $ runExceptT $ largestFirst opts outs utxo of
Left _ -> genSelection outs
@@ -109,7 +109,7 @@ import Data.Quantity
import Data.Time.Clock
( secondsToDiffTime )
import Data.Word
( Word32 )
( Word16, Word32 )
import GHC.Generics
( Generic )
import Test.Hspec
@@ -744,7 +744,7 @@ genTxOut coins = do

genSelection :: NonEmpty TxOut -> Gen CoinSelection
genSelection outs = do
let opts = CS.CoinSelectionOptions 100 (const $ Right ())
let opts = CS.CoinSelectionOptions (const 100) (const $ Right ())
utxo <- vectorOf (NE.length outs * 3) arbitrary >>= genUTxO
case runIdentity $ runExceptT $ largestFirst opts outs utxo of
Left _ -> genSelection outs
@@ -165,7 +165,7 @@ genTxOut coins = do

genSelection :: NonEmpty TxOut -> Gen CoinSelection
genSelection outs = do
let opts = CS.CoinSelectionOptions 100 (const $ Right ())
let opts = CS.CoinSelectionOptions (const 100) (const $ Right ())
utxo <- vectorOf (NE.length outs * 3) arbitrary >>= genUTxO
case runIdentity $ runExceptT $ largestFirst opts outs utxo of
Left _ -> genSelection outs

0 comments on commit 58583f1

Please sign in to comment.
You can’t perform that action at this time.