Adding property tests

Finetuning tests and adding rest properties

Add estimate function pointers

src/Cardano/Wallet/CoinSelection.hs

@@ -105,6 +105,9 @@ data FeeOptions = FeeOptions
       -> [Coin]
       -> Coin
       -- ^ Estimate fees based on number of inputs and values of the outputs
+      -- Some pointers :
+      --     a: 155381 # absolute minimal fees per transaction
+      --     b: 43.946 # additional minimal fees per byte of transaction size
     , dustThreshold
       :: Coin
       -- ^ Change addresses below the given threshold will be evicted
@@ -113,9 +116,10 @@ data FeeOptions = FeeOptions
     } deriving (Generic)
 
 newtype FeeError =
-    CannotCoverFee Word64 deriving (Show, Eq)
+    CannotCoverFee Word64
     -- ^ UTxO exhausted during fee covering
     -- We record what amount missed to cover the fee
+    deriving (Show, Eq)
 
 -- | Given the coin selection result from a policy run, adjust the outputs
 -- for fees, potentially returning additional inputs that we need to cover

test/unit/Cardano/Wallet/CoinSelectionSpec.hs

@@ -24,18 +24,34 @@ import Cardano.Wallet.CoinSelection
     , FeeOptions (..)
     , adjustForFees
     )
+import Cardano.Wallet.CoinSelection.LargestFirst
+    ( largestFirst )
 import Cardano.Wallet.Primitive.Types
     ( Address (..), Coin (..), Hash (..), TxIn (..), TxOut (..), UTxO (..) )
 import Control.Monad.Trans.Except
     ( ExceptT, runExceptT )
+import Data.Either
+    ( isRight, lefts )
+import Data.Functor.Identity
+    ( Identity (runIdentity) )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Word
     ( Word64, Word8 )
 import Test.Hspec
-    ( Spec, SpecWith, describe, it, shouldBe )
+    ( Spec, SpecWith, describe, it, shouldBe, shouldSatisfy )
 import Test.QuickCheck
-    ( Arbitrary (..), Gen, choose, generate, oneof, scale, vectorOf )
+    ( Arbitrary (..)
+    , Gen
+    , Property
+    , choose
+    , generate
+    , oneof
+    , property
+    , scale
+    , vectorOf
+    , (==>)
+    )
 
 import qualified Data.ByteString as BS
 import qualified Data.List as L
@@ -345,6 +361,137 @@ spec = do
             , csChngs = [2]
             })
 
+        feeUnitTest (FeeFixture
+            { fInps = [10,10]
+            , fOuts = [7,7]
+            , fChngs = [3,3]
+            , fExtraUtxo = [3,3]
+            , fFee = 0
+            , fDust = 0
+            }) (Right $ FeeOutput
+            { csInps = [10,10]
+            , csOuts = [7,7]
+            , csChngs = [3,3]
+            })
+
+
+    describe "Fee calculation properties" $ do
+        it "forall CoinSelection,\
+            \computing the fee of 0 ends up with the same CoinSelection"
+            (property propTheSameCoinSelection)
+        it "forall CoinSelection with UTxO empty,\
+            \computing the fee is deterministic"
+            (property propDeterministic)
+        it "forall CoinSelection with UTxO empty,\
+            \computing the nonzero fee gives rise to reduced changes"
+            (property propReducedChanges)
+        it "forall CoinSelection with UTxO non-empty,\
+            \computing the nonzero fee is deterministic when error arises"
+            (property propDeterministicError)
+        it "forall CoinSelection with UTxO empty,\
+            \when computing the nonzero fee gives rise to error, \
+            \then the same setup with UTxO non-empty gives rise increased inputs,\
+            \if successful"
+            (property propIncreasedInputs)
+
+propTheSameCoinSelection
+    :: FeeCase
+    -> Property
+propTheSameCoinSelection (FeeCase (CoveringCase (utxo, txOuts)) extraUtxo _) = do
+    isRight selection ==> let Right s = selection in prop (s, extraUtxo)
+  where
+    prop (coinSel, utxo') = do
+        let feeOpt = feeOptions 0 0
+        coinSel' <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        coinSel' `shouldBe` (pure coinSel)
+    selection = runIdentity $ runExceptT $
+        largestFirst (CoinSelectionOptions 100) utxo txOuts
+
+propDeterministic
+    :: FeeCase
+    -> Property
+propDeterministic (FeeCase (CoveringCase (utxo, txOuts)) _ (fee, dust)) = do
+    isRight selection ==> let Right s = selection in prop s
+  where
+    prop coinSel = do
+        let feeOpt = feeOptions fee dust
+        let utxo' = UTxO Map.empty
+        resultOne <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        resultTwo <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        resultOne `shouldBe` resultTwo
+    selection = runIdentity $ runExceptT $
+        largestFirst (CoinSelectionOptions 100) utxo txOuts
+
+propReducedChanges
+    :: FeeCase
+    -> Property
+propReducedChanges (FeeCase (CoveringCase (utxo, txOuts)) _ (fee, dust)) = do
+    isRight selection ==> let Right s = selection in prop s
+  where
+    prop coinSel = do
+        let feeOpt = feeOptions fee dust
+        let utxo' = UTxO Map.empty
+        result <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        case result of
+            Right coinSel' -> do
+                let chgs' = sum $ map getCoin $ change coinSel'
+                let chgs = sum $ map getCoin $ change coinSel
+                chgs' `shouldSatisfy` (<= chgs)
+            Left _ ->
+                -- just tautology
+                result `shouldBe` result
+    selection = runIdentity $ runExceptT $
+        largestFirst (CoinSelectionOptions 100) utxo txOuts
+
+propDeterministicError
+    :: FeeCase
+    -> Property
+propDeterministicError (FeeCase (CoveringCase (utxo, txOuts)) _ (fee, dust)) = do
+    isRight selection ==> let Right s = selection in prop s
+  where
+    prop coinSel = do
+        let feeOpt = feeOptions fee dust
+        let utxo' = UTxO Map.empty
+        result <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        case result of
+            Right _ -> do
+                -- just tautology
+                result `shouldBe` result
+            Left err -> do
+                resultSecond <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+                [err] `shouldBe` (lefts [resultSecond])
+    selection = runIdentity $ runExceptT $
+        largestFirst (CoinSelectionOptions 100) utxo txOuts
+
+propIncreasedInputs
+    :: FeeCase
+    -> Property
+propIncreasedInputs (FeeCase (CoveringCase (utxo, txOuts)) extraUtxo (fee, dust)) = do
+    isRight selection ==> let Right s = selection in prop s
+  where
+    prop coinSel = do
+        let feeOpt = feeOptions fee dust
+        let utxo' = UTxO Map.empty
+        result <- runExceptT $ adjustForFees feeOpt utxo' coinSel
+        case result of
+            Right _ -> do
+                -- just tautology
+                result `shouldBe` result
+            Left _ -> do
+                resultSecond <- runExceptT $ adjustForFees feeOpt extraUtxo coinSel
+                case resultSecond of
+                    Right coinSel'' -> do
+                        let computeInps = sum . map (getCoin . coin . snd ) . inputs
+                        let inps = computeInps coinSel
+                        let inps' = computeInps coinSel''
+                        inps `shouldSatisfy` (<= inps')
+                    Left _ ->
+                        -- just tautology
+                        result `shouldBe` result
+    selection = runIdentity $ runExceptT $
+        largestFirst (CoinSelectionOptions 100) utxo txOuts
+
+
 feeOptions
     :: Word64
     -> Word64
@@ -492,10 +639,29 @@ coinSelectionUnitTest run lbl expected (Fixture n utxoCoins txOutsCoins) =
                 $ NE.map Coin txOutsCoins
         pure (utxo, txOuts)
 
+-- | Data for running fee calculation properties
+data FeeCase = FeeCase
+    { coveringCase :: CoveringCase
+     -- ^ inputs from wich largestFirst can be calculated
+    , availableUtxo :: UTxO
+     -- ^ additional UTxO from which fee calculation will pick needed coins to cover fee
+    , feeDust :: (Word64, Word64)
+     -- ^ constant fee and dust threshold
+    }
+    deriving Show
+
 {-------------------------------------------------------------------------------
                             Arbitrary Instances
 -------------------------------------------------------------------------------}
 
+instance Arbitrary FeeCase where
+    arbitrary = do
+        cc <- arbitrary
+        utxo <- arbitrary
+        fee <- choose (100000, 500000)
+        dust <- choose (0, 10000)
+        return $ FeeCase cc utxo (fee, dust)
+
 instance Arbitrary CoveringCase where
     arbitrary = do
         n <- choose (1, 10)