Skip to content

Commit

Permalink
factor out common test logic in largest first and random coin selection
Browse files Browse the repository at this point in the history
  • Loading branch information
@KtorZ
KtorZ committed Apr 4, 2019
1 parent cddc877 commit 6596d6e
Show file tree
Hide file tree
Showing 3 changed files with 275 additions and 380 deletions.
250 changes: 69 additions & 181 deletions test/unit/Cardano/Wallet/CoinSelection/LargestFirstSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,15 +12,10 @@ import Cardano.Wallet.CoinSelection
( CoinSelection (..), CoinSelectionError (..), CoinSelectionOptions (..) )
import Cardano.Wallet.CoinSelection.LargestFirst
( largestFirst )
import Cardano.Wallet.CoinSelectionSpec
( CoveringCase (..), Fixture (..), coinSelectionUnitTest )
import Cardano.Wallet.Primitive.Types
( Address (..)
, Coin (..)
, Hash (..)
, TxIn (..)
, TxOut (..)
, UTxO (..)
, excluding
)
( Coin (..), TxOut (..), UTxO (..), excluding )
import Control.Monad
( unless )
import Control.Monad.Trans.Except
Expand All @@ -31,25 +26,11 @@ import Data.Functor.Identity
( Identity (runIdentity) )
import Data.List.NonEmpty
( NonEmpty (..) )
import Data.Word
( Word64, Word8 )
import Test.Hspec
( Expectation, Spec, describe, it, shouldBe, shouldSatisfy )
( Spec, describe, it, shouldSatisfy )
import Test.QuickCheck
( Arbitrary (..)
, Gen
, Property
, choose
, generate
, oneof
, property
, scale
, vectorOf
, (===)
, (==>)
)
( Property, property, (===), (==>) )

import qualified Data.ByteString as BS
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
Expand All @@ -58,129 +39,91 @@ import qualified Data.Set as Set
spec :: Spec
spec = do
describe "Coin selection : LargestFirst algorithm unit tests" $ do
it "one input per small output" $ do
(coinSelectionUnitTest
Fixture
{ maxNumOfInputs = 100
, utxoInputs = [10,10,17]
, txOutputs = 17 :| []
, expectedResult = Right [17]
})
it "one input per big output" $ do
(coinSelectionUnitTest
Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 1 :| []
, expectedResult = Right [17]
})
it "two inputs per output" $ do
(coinSelectionUnitTest
Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 18 :| []
, expectedResult = Right [12, 17]
})
it "three inputs per output" $ do
(coinSelectionUnitTest
Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 30 :| []
, expectedResult = Right [10, 12, 17]
})
it "NotEnoughMoney error expected when not enough coins" $ do
(coinSelectionUnitTest
Fixture
coinSelectionUnitTest largestFirst "" (Right [17]) $ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [10,10,17]
, txOutputs = 17 :| []
}

coinSelectionUnitTest largestFirst "" (Right [17]) $ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 1 :| []
}

coinSelectionUnitTest largestFirst "" (Right [12, 17]) $ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 18 :| []
}

coinSelectionUnitTest largestFirst "" (Right [10, 12, 17]) $ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 30 :| []
}

coinSelectionUnitTest largestFirst "" (Right [6,10,5]) $ Fixture
{ maxNumOfInputs = 3
, utxoInputs = [1,2,10,6,5]
, txOutputs = 11 :| [1]
}

coinSelectionUnitTest
largestFirst
"not enough coins"
(Left $ NotEnoughMoney 39 40)
$ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 40 :| []
, expectedResult = Left $ NotEnoughMoney 39 40
})
it "NotEnoughMoney error expected when not enough coins and utxo not fragmented enough" $ do
(coinSelectionUnitTest
Fixture
}

coinSelectionUnitTest
largestFirst
"not enough coin & not fragmented enough"
(Left $ NotEnoughMoney 39 43)
$ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,10,17]
, txOutputs = 40 :| [1,1,1]
, expectedResult = Left $ NotEnoughMoney 39 43
})
it "UtxoNotEnoughFragmented error expected when enough coins and utxo not fragmented enough" $ do
(coinSelectionUnitTest
Fixture
}

coinSelectionUnitTest
largestFirst
"enough coins, but not fragmented enough"
(Left $ UtxoNotEnoughFragmented 3 4)
$ Fixture
{ maxNumOfInputs = 100
, utxoInputs = [12,20,17]
, txOutputs = 40 :| [1,1,1]
, expectedResult = Left $ UtxoNotEnoughFragmented 3 4
})
it "happy path with correct maximumNumberOfInputs - 3 inputs for 2 outputs" $ do
(coinSelectionUnitTest
Fixture
{ maxNumOfInputs = 3
, utxoInputs = [1,2,10,6,5]
, txOutputs = 11 :| [1]
, expectedResult = Right [6,10,5]
})
it "happy path with too strict maximumNumberOfInputs result in error - 3 inputs for 2 outputs" $ do
(coinSelectionUnitTest
Fixture
}

coinSelectionUnitTest
largestFirst
"enough coins but, strict maximumNumberOfInputs"
(Left $ MaximumInputsReached 2)
$ Fixture
{ maxNumOfInputs = 2
, utxoInputs = [1,2,10,6,5]
, txOutputs = 11 :| [1]
, expectedResult = Left $ MaximumInputsReached 2
})
}

describe "Coin selection properties : LargestFirst algorithm" $ do
it "forall (UTxO, NonEmpty TxOut), \
\ running algorithm twice yields exactly the same result"
it "forall (UTxO, NonEmpty TxOut), running algorithm twice yields \
\exactly the same result"
(property propDeterministic)
it "forall (UTxO, NonEmpty TxOut), \
\ there's at least as many selected inputs as there are requested outputs"
it "forall (UTxO, NonEmpty TxOut), there's at least as many selected \
\inputs as there are requested outputs"
(property propAtLeast)
it "forall (UTxO, NonEmpty TxOut), for all selected input, \
\ there's no bigger input in the UTxO that is not already in the selected inputs."
it "forall (UTxO, NonEmpty TxOut), for all selected input, there's no \
\bigger input in the UTxO that is not already in the selected inputs"
(property propInputDecreasingOrder)

{-------------------------------------------------------------------------------
Properties and unit test generic scenario
Properties
-------------------------------------------------------------------------------}

data Fixture = Fixture
{ maxNumOfInputs :: Word64
, utxoInputs :: [Word64]
, txOutputs :: NonEmpty Word64
, expectedResult :: Either CoinSelectionError [Word64]
} deriving Show


coinSelectionUnitTest
:: Fixture
-> Expectation
coinSelectionUnitTest (Fixture n utxoCoins txOutsCoins expected) = do
(utxo,txOuts) <- setup

result <- runExceptT $ do
CoinSelection inps _ _ <-
largestFirst (CoinSelectionOptions n) utxo txOuts
return $ map (getCoin . coin . snd) inps

result `shouldBe` expected
where
setup :: IO (UTxO, NonEmpty TxOut)
setup = do
ins <- generate $ vectorOf (L.length utxoCoins) arbitrary
addrs <- generate $ vectorOf (L.length utxoCoins) arbitrary
let utxo = UTxO $ Map.fromList
$ L.zip ins
$ L.zipWith TxOut addrs
$ map Coin utxoCoins
txOutsAddrs <- generate $ vectorOf (L.length txOutsCoins) arbitrary
let txOuts = NE.zipWith TxOut (NE.fromList txOutsAddrs)
$ NE.map Coin txOutsCoins
pure (utxo, txOuts)


propDeterministic
:: CoveringCase
-> Property
Expand Down Expand Up @@ -218,58 +161,3 @@ propInputDecreasingOrder (CoveringCase (utxo, txOuts)) =
getExtremumValue f = f . map (getCoin . coin . snd)
selection = runIdentity $ runExceptT $
largestFirst (CoinSelectionOptions 100) utxo txOuts


{-------------------------------------------------------------------------------
Test Data
-------------------------------------------------------------------------------}

newtype CoveringCase = CoveringCase { getCoveringCase :: (UTxO, NonEmpty TxOut)}
deriving Show

instance Arbitrary CoveringCase where
arbitrary = do
n <- choose (1, 10)
txOutsNonEmpty <- NE.fromList <$> vectorOf n arbitrary
utxo <- arbitrary
return $ CoveringCase (utxo, txOutsNonEmpty)

instance Arbitrary (Hash "Tx") where
-- No Shrinking
arbitrary = do
wds <- vectorOf 10 arbitrary :: Gen [Word8]
let bs = BS.pack wds
pure $ Hash bs

instance Arbitrary Address where
-- No Shrinking
arbitrary = oneof
[ pure $ Address "ADDR01"
, pure $ Address "ADDR02"
, pure $ Address "ADDR03"
]

instance Arbitrary Coin where
-- No Shrinking
arbitrary = Coin <$> choose (1, 100000)

instance Arbitrary TxOut where
-- No Shrinking
arbitrary = TxOut
<$> arbitrary
<*> arbitrary

instance Arbitrary TxIn where
-- No Shrinking
arbitrary = TxIn
<$> arbitrary
<*> scale (`mod` 3) arbitrary -- No need for a high indexes

instance Arbitrary UTxO where
shrink (UTxO utxo) = UTxO <$> shrink utxo
arbitrary = do
n <- choose (1, 100)
utxo <- zip
<$> vectorOf n arbitrary
<*> vectorOf n arbitrary
return $ UTxO $ Map.fromList utxo
Loading

0 comments on commit 6596d6e

Please sign in to comment.