From fea97a00c15e6f8e87ad555a2318ffa3df4ec851 Mon Sep 17 00:00:00 2001 From: Pawel Jakubas Date: Wed, 10 Apr 2019 15:58:32 +0200 Subject: [PATCH] Adding tons of unit tests and revert to double conversion --- cardano-wallet.cabal | 1 + src/Cardano/Wallet/CoinSelection/Fee.hs | 63 ++-- .../Cardano/Wallet/CoinSelection/FeeSpec.hs | 333 ++++++++++++++++++ test/unit/Cardano/Wallet/CoinSelectionSpec.hs | 3 +- 4 files changed, 373 insertions(+), 27 deletions(-) create mode 100644 test/unit/Cardano/Wallet/CoinSelection/FeeSpec.hs diff --git a/cardano-wallet.cabal b/cardano-wallet.cabal index b407f3cb3e5..d7f2ae03e6f 100644 --- a/cardano-wallet.cabal +++ b/cardano-wallet.cabal @@ -153,6 +153,7 @@ test-suite unit Cardano.Wallet.BinarySpec Cardano.Wallet.Binary.PackfileSpec Cardano.Wallet.CoinSelectionSpec + Cardano.Wallet.CoinSelection.FeeSpec Cardano.Wallet.CoinSelection.LargestFirstSpec Cardano.Wallet.CoinSelection.RandomSpec Cardano.Wallet.DBSpec diff --git a/src/Cardano/Wallet/CoinSelection/Fee.hs b/src/Cardano/Wallet/CoinSelection/Fee.hs index d5deccfcf08..5a6bdbacaf5 100644 --- a/src/Cardano/Wallet/CoinSelection/Fee.hs +++ b/src/Cardano/Wallet/CoinSelection/Fee.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE RankNTypes #-} -- | @@ -19,6 +20,8 @@ import Cardano.Wallet.CoinSelection.Random ( distance, pickRandom ) import Cardano.Wallet.Primitive.Types ( Coin (..), TxIn, TxOut (..), UTxO (..), invariant, isValidCoin ) +import Control.Monad.IO.Class + ( MonadIO, liftIO ) import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Except @@ -32,6 +35,8 @@ import Data.Bifunctor import Data.Word ( Word64 ) +import Debug.Trace + import qualified Data.List as L -- | Given the coin selection result from a policy run, adjust the outputs @@ -61,14 +66,16 @@ import qualified Data.List as L -- percentage of the fee (depending on how many change outputs the -- algorithm happened to choose). adjustForFees - :: forall m. MonadRandom m + :: forall m. (MonadRandom m, MonadIO m) => FeeOptions -> UTxO -> CoinSelection -> ExceptT FeeError m CoinSelection adjustForFees opt utxo coinSel = do + liftIO $ print coinSel coinSel'@(CoinSelection inps' outs' chgs') <- senderPaysFee opt utxo coinSel + liftIO $ print coinSel' let estimatedFee = feeUpperBound opt coinSel let actualFee = computeFee coinSel' @@ -96,7 +103,7 @@ adjustForFees opt utxo coinSel = do pure (CoinSelection neInps neOuts chgs') senderPaysFee - :: forall m. MonadRandom m + :: forall m. (MonadRandom m, MonadIO m) => FeeOptions -> UTxO -> CoinSelection @@ -115,8 +122,13 @@ senderPaysFee opt utxo = go reduceChangeOutputs totalFee chgs = case (filter (/= Coin 0) . removeDust) chgs of [] -> - (removeDust chgs, totalFee) - xs -> + trace ("reduceChangeOutputs - []") $ (removeDust chgs, totalFee) + xs -> trace ("reduceChangeOutputs - divvy - totalFee : " + <> (show totalFee) + <> " xs : " + <> (show xs) + <> (" res: ") + <> (show $ divvyFee totalFee xs)) $ bimap removeDust (Coin . sum . map getCoin) $ L.unzip $ map reduceSingleChange @@ -133,7 +145,7 @@ senderPaysFee opt utxo = go go - :: forall m. MonadRandom m + :: forall m. (MonadRandom m, MonadIO m) => CoinSelection -> ExceptT FeeError m CoinSelection go coinSel@(CoinSelection inps outs chgs) = do @@ -141,10 +153,13 @@ senderPaysFee opt utxo = go -- We compute fees using all inputs, outputs and changes since -- all of them have an influence on the fee calculation. let upperBound = feeUpperBound opt coinSel - + liftIO $ print "upperBound:" + liftIO $ print upperBound -- 2/ Substract fee from all change outputs, proportionally to their value. - let (chgs', remainingFee) = + let alls@(chgs', remainingFee) = reduceChangeOutputs upperBound chgs + liftIO $ print "alls:" + liftIO $ print alls -- 3.1/ -- Should the change cover the fee, we're (almost) good. By removing @@ -196,28 +211,26 @@ divvyFee _ outs | (Coin 0) `elem` outs = divvyFee fee outs = map (\a -> (feeForOut a, a)) outs where - totalOut :: Word64 - totalOut = (sum . map getCoin) outs + totalOuts :: Word64 + totalOuts = (sum . map getCoin) outs - -- The ratio will be between 0 and 1 so cannot overflow feeForOut :: Coin -> Coin - feeForOut (Coin a) = - let res = valueAdjust - (a `div` totalOut, a `quot` totalOut) - fee + feeForOut out = + let res = valueAdjust (valueRatio out (Coin totalOuts)) fee in if isValidCoin res then res else error "feeForOut : fee exceeded maximum valid value for Coin" - valueAdjust - :: (Word64, Word64) - -> Coin - -> Coin - valueAdjust (natural, remainder) (Coin c) = - let remainder' = c `quot` remainder - in Coin $ natural * c + c `div` remainder + (if remainder' == 0 then 0 else 1) + valueRatio :: Coin -> Coin -> Double + valueRatio c1 c2 = (coinToDouble c1) / (coinToDouble c2) + + valueAdjust :: Double -> Coin -> Coin + valueAdjust d c = + Coin $ ceiling (d * (coinToDouble c)) + coinToDouble :: Coin -> Double + coinToDouble = fromIntegral . getCoin coverRemainingFee :: forall m. MonadRandom m @@ -310,7 +323,7 @@ computeFee (CoinSelection inps outs chgs) = -- Some remaining inputs together. At this point, we've removed -- all outputs and changes, so what's left are simply the actual fees. -- It's unrealistic to imagine them being bigger than the max coin value. - collapse plus [] = + collapse plus [] = trace (("collapse : plus : "<>(show plus))) $ invariant "fees are bigger than max coin value" (Coin . sum $ map getCoin plus) @@ -320,13 +333,13 @@ computeFee (CoinSelection inps outs chgs) = -- overflow. Therefore, we remove outputs to inputs until there's no outputs -- left to remove. collapse (p:ps) (m:ms) - | p > m = + | p > m = trace (("collapse : p>m : "<>(show p)<>(" > ")<>(show m)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $ let p' = Coin $ distance (getCoin p) (getCoin m) in collapse (p':ps) ms - | p < m = + | p < m = trace (("collapse : p(show p)<>(" < ")<>(show m)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $ let m' = Coin $ distance (getCoin p) (getCoin m) in collapse ps (m':ms) - | otherwise = collapse ps ms + | otherwise = trace (("collapse : p==m : "<>(show p)<>(" ps:")<>(show ps)<>(" ms")<>(show ms))) $ collapse ps ms -- This branch can only happens if we've depleted all our inputs and there -- are still some outputs left to remove from them. If means the total value diff --git a/test/unit/Cardano/Wallet/CoinSelection/FeeSpec.hs b/test/unit/Cardano/Wallet/CoinSelection/FeeSpec.hs new file mode 100644 index 00000000000..4df03d07546 --- /dev/null +++ b/test/unit/Cardano/Wallet/CoinSelection/FeeSpec.hs @@ -0,0 +1,333 @@ +module Cardano.Wallet.CoinSelection.FeeSpec + ( spec + ) where + +import Prelude + + +import Cardano.Wallet.CoinSelection + ( CoinSelection (..), FeeError (..), FeeOptions (..) ) +import Cardano.Wallet.CoinSelection.Fee + ( adjustForFees ) +import Cardano.Wallet.CoinSelectionSpec + () +import Cardano.Wallet.Primitive.Types + ( Coin (..), TxOut (..), UTxO (..) ) +import Control.Monad.Trans.Except + ( runExceptT ) +import Data.Word + ( Word64 ) +import Test.Hspec + ( Spec, SpecWith, describe, it, shouldBe ) +import Test.QuickCheck + ( Arbitrary (..), generate, vectorOf ) + +import qualified Data.List as L +import qualified Data.Map.Strict as Map + +spec :: Spec +spec = do + describe "Fee calculation : unit tests" $ do + feeUnitTest (FeeFixture + { fInps = [20] + , fOuts = [17] + , fChngs = [3] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20] + , csOuts = [17] + , csChngs = [] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [18,18] + , fChngs = [2,2] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [18,18] + , csChngs = [1,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [17,18] + , fChngs = [3,2] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [17,18] + , csChngs = [1,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [16,18] + , fChngs = [4,2] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [16,18] + , csChngs = [2,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [15,18] + , fChngs = [5,2] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [15,18] + , csChngs = [3,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [14,18] + , fChngs = [6,2] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [14,18] + , csChngs = [4,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [14,14] + , fChngs = [6,6] + , fExtraUtxo = [] + , fFee = 2 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [14,14] + , csChngs = [5,5] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,18,19] + , fChngs = [6,2,1] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,18,19] + , csChngs = [4,1] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,18,19] + , fChngs = [6,2,1] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 1 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,18,19] + , csChngs = [3] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,17,19] + , fChngs = [6,3,1] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,17,19] + , csChngs = [4,2] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,17,19] + , fChngs = [6,3,1] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 1 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,17,19] + , csChngs = [4,2] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20,20] + , fOuts = [14,17,19] + , fChngs = [6,3,1] + , fExtraUtxo = [] + , fFee = 3 + , fDust = 2 + }) (Right $ FeeOutput + { csInps = [20,20,20] + , csOuts = [14,17,19] + , csChngs = [4] + }) + + feeUnitTest (FeeFixture + { fInps = [20] + , fOuts = [17] + , fChngs = [3] + , fExtraUtxo = [] + , fFee = 4 + , fDust = 0 + }) (Left $ CannotCoverFee 1) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [16,18] + , fChngs = [4,2] + , fExtraUtxo = [] + , fFee = 6 + , fDust = 0 + }) (Right $ FeeOutput + { csInps = [20,20] + , csOuts = [16,18] + , csChngs = [] + }) + + feeUnitTest (FeeFixture + { fInps = [20,20] + , fOuts = [16,18] + , fChngs = [4,2] + , fExtraUtxo = [] + , fFee = 6 + , fDust = 2 + }) (Left $ CannotCoverFee 2) + + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fExtraUtxo = [1] + , fFee = 5 + , fDust = 0 + }) (Left $ CannotCoverFee 2) + + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fExtraUtxo = [2] + , fFee = 5 + , fDust = 0 + }) (Left $ OutOfBoundFee 0 5) + + feeUnitTest (FeeFixture + { fInps = [10] + , fOuts = [7] + , fChngs = [3] + , fExtraUtxo = [1,1] + , fFee = 5 + , fDust = 0 + }) (Left $ OutOfBoundFee 0 5) + +feeOptions + :: Word64 + -> Word64 + -> FeeOptions +feeOptions fee dust = FeeOptions + { estimate = \_num _outs -> + Coin fee + , dustThreshold = + Coin dust + } + + +feeUnitTest + :: FeeFixture + -> Either FeeError FeeOutput + -> SpecWith () +feeUnitTest (FeeFixture inps outs chngs extraUtxo fee dust) expected = it title $ do + (utxo, coinSel) <- setup + + result <- runExceptT $ do + (CoinSelection inps' outs' chngs') <- + adjustForFees (feeOptions fee dust) utxo coinSel + return $ FeeOutput + { + csInps = map (getCoin . coin . snd) inps' + , csOuts = map (getCoin . coin) outs' + , csChngs = map getCoin chngs' + } + + result `shouldBe` expected + where + setup :: IO (UTxO, CoinSelection) + setup = do + txUtxoIns <- generate $ vectorOf (L.length extraUtxo) arbitrary + txUtxoOutsAddr <- generate $ vectorOf (L.length extraUtxo) arbitrary + let utxo = UTxO $ Map.fromList $ L.zip txUtxoIns + $ L.zipWith TxOut txUtxoOutsAddr + $ map Coin extraUtxo + + coinSelIns <- generate $ vectorOf (L.length inps) arbitrary + coinSelInsOutsAddr <- generate $ vectorOf (L.length inps) arbitrary + let coinSelInps = L.zip coinSelIns + $ L.zipWith TxOut coinSelInsOutsAddr + $ map Coin inps + + + coinSelOutsAddr <- generate $ vectorOf (L.length outs) arbitrary + let coinSelOuts = L.zipWith TxOut coinSelOutsAddr + $ map Coin outs + + let coinSelChngs = map Coin chngs + + pure (utxo, CoinSelection coinSelInps coinSelOuts coinSelChngs) + + title :: String + title = mempty + <> "CoinSelection (inps=" <> show inps + <> "outs=" <> show outs + <> "chngs=" <> show chngs + <> "), UTxO=" <> show extraUtxo + <> "), fee=" <> show fee + <> " --> " <> show expected + + +-- | A fixture for testing the fee calculation +data FeeFixture = FeeFixture + { fInps :: [Word64] + -- ^ Value (in Lovelace) & number of coins in inputs + , fOuts :: [Word64] + -- ^ Value (in Lovelace) & number of requested outputs + , fChngs :: [Word64] + -- ^ Value (in Lovelace) & number of changes + , fExtraUtxo :: [Word64] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , fFee :: Word64 + -- ^ Value (in Lovelace) of rigid fee + , fDust :: Word64 + -- ^ Value (in Lovelace) of dust + } deriving Show + +-- | A fee calculation output +data FeeOutput = FeeOutput + { csInps :: [Word64] + -- ^ Value (in Lovelace) & number of available coins in the UTxO + , csOuts :: [Word64] + -- ^ Value (in Lovelace) & number of requested outputs + , csChngs :: [Word64] + -- ^ Value (in Lovelace) & number of changes + } deriving (Show, Eq) diff --git a/test/unit/Cardano/Wallet/CoinSelectionSpec.hs b/test/unit/Cardano/Wallet/CoinSelectionSpec.hs index a79db52735c..4f9dcf6ca85 100644 --- a/test/unit/Cardano/Wallet/CoinSelectionSpec.hs +++ b/test/unit/Cardano/Wallet/CoinSelectionSpec.hs @@ -36,7 +36,6 @@ import qualified Data.List as L import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map - spec :: Spec spec = return () @@ -70,7 +69,7 @@ coinSelectionUnitTest run lbl expected (Fixture n utxoCoins txOutsCoins) = it title $ do (utxo,txOuts) <- setup result <- runExceptT $ do - CoinSelection inps _ _ <- + (CoinSelection inps _ _) <- run (CoinSelectionOptions n) utxo txOuts return $ map (getCoin . coin . snd) inps result `shouldBe` expected