Merge pull request #77 from input-output-hk/jonathanknowles/fix-migra…

…tion

Prevent the migration algorithm from creating money.

src/library/Cardano/CoinSelection/Algorithm/Migration.hs

@@ -33,6 +33,7 @@ import Cardano.CoinSelection
     , CoinSelectionLimit (..)
     , coinMapFromList
     , coinMapToList
+    , coinMapValue
     , sumChange
     , sumInputs
     )
@@ -42,13 +43,14 @@ import Cardano.CoinSelection.Fee
     , FeeBalancingPolicy (..)
     , FeeEstimator (..)
     , FeeOptions (..)
+    , isDust
     )
 import Control.Monad.Trans.State
     ( State, evalState, get, put )
 import Data.List.NonEmpty
     ( NonEmpty ((:|)) )
 import Data.Maybe
-    ( fromMaybe, mapMaybe )
+    ( fromMaybe )
 import Data.Word
     ( Word16 )
 import GHC.Generics
@@ -113,19 +115,20 @@ selectCoins options (BatchSize batchSize) utxo =
     -- Note that the selection may look a bit weird at first sight as it has
     -- no outputs (we are paying everything to ourselves!).
     mkCoinSelection :: [CoinMapEntry i] -> CoinSelection i o
-    mkCoinSelection inps = CoinSelection
-        { inputs = coinMapFromList inps
-        , outputs = mempty
-        , change =
-            let chgs = mapMaybe (noDust . entryValue) inps
-            in if null chgs then [threshold] else chgs
-        }
+    mkCoinSelection inputEntries = CoinSelection {inputs, outputs, change}
       where
-        threshold = unDustThreshold dustThreshold
-        noDust :: Coin -> Maybe Coin
-        noDust c
-            | c < threshold = Nothing
-            | otherwise = Just c
+        inputs = coinMapFromList inputEntries
+        outputs = mempty
+        change
+            | null nonDustInputCoins && totalInputValue >= smallestNonDustCoin =
+                [smallestNonDustCoin]
+            | otherwise =
+                nonDustInputCoins
+        nonDustInputCoins = filter
+            (not . isDust dustThreshold)
+            (entryValue <$> inputEntries)
+        smallestNonDustCoin = C.succ $ unDustThreshold dustThreshold
+        totalInputValue = coinMapValue inputs
 
     -- | Attempt to balance the coin selection by reducing or increasing the
     -- change values based on the computed fees.

src/library/Cardano/CoinSelection/Fee.hs

@@ -31,6 +31,7 @@ module Cardano.CoinSelection.Fee
 
       -- * Dust Processing
     , DustThreshold (..)
+    , isDust
     , coalesceDust
 
       -- # Internal Functions
@@ -119,6 +120,17 @@ newtype DustThreshold = DustThreshold { unDustThreshold :: Coin }
     deriving stock (Eq, Generic, Ord)
     deriving Show via (Quiet DustThreshold)
 
+-- | Returns 'True' if and only if the given 'Coin' is a __dust coin__
+--   according to the given 'DustThreshold'.
+--
+-- A coin is considered to be a dust coin if it is /less than or equal to/
+-- the threshold.
+--
+-- See 'DustThreshold'.
+--
+isDust :: DustThreshold -> Coin -> Bool
+isDust (DustThreshold dt) c = c <= dt
+
 -- | Provides a function capable of __estimating__ the transaction fee required
 --   for a given coin selection, according to the rules of a particular
 --   blockchain.
@@ -618,10 +630,10 @@ distributeFee (Fee feeTotal) coinsUnsafe =
 -- >>> all (/= Coin 0) (coalesceDust threshold coins)
 --
 coalesceDust :: DustThreshold -> NonEmpty Coin -> [Coin]
-coalesceDust (DustThreshold threshold) coins =
+coalesceDust threshold coins =
     splitCoin valueToDistribute coinsToKeep
   where
-    (coinsToKeep, coinsToRemove) = NE.partition (> threshold) coins
+    (coinsToRemove, coinsToKeep) = NE.partition (isDust threshold) coins
     valueToDistribute = F.fold coinsToRemove
 
 -- Splits up the given coin of value __@v@__, distributing its value over the

src/test/Cardano/CoinSelection/Algorithm/MigrationSpec.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -117,27 +118,27 @@ spec = do
 
     describe "selectCoins properties" $ do
         it "No coin selection has outputs" $
-            property $ withMaxSuccess 10000 $ prop_onlyChangeOutputs
+            property $ withMaxSuccess 10_000 $ prop_onlyChangeOutputs
                 @(Wrapped TxIn) @Address
 
-        it "Every coin in the selection change >= minimum threshold coin" $
-            property $ withMaxSuccess 10000 $ prop_noLessThanThreshold
+        it "Every coin in the selection change > dust threshold" $
+            property $ withMaxSuccess 10_000 $ prop_allAboveThreshold
                 @(Wrapped TxIn) @Address
 
         it "Total input UTxO value >= sum of selection change coins" $
-            property $ withMaxSuccess 10000 $ prop_inputsGreaterThanOutputs
+            property $ withMaxSuccess 10_000 $ prop_inputsGreaterThanOutputs
                 @(Wrapped TxIn) @Address
 
         it "Every selection input is unique" $
-            property $ withMaxSuccess 10000 $ prop_inputsAreUnique
+            property $ withMaxSuccess 10_000 $ prop_inputsAreUnique
                 @(Wrapped TxIn) @Address
 
         it "Every selection input is a member of the UTxO" $
-            property $ withMaxSuccess 10000 $ prop_inputsStillInUTxO
+            property $ withMaxSuccess 10_000 $ prop_inputsStillInUTxO
                 @(Wrapped TxIn) @Address
 
         it "Every coin selection is well-balanced" $
-            property $ withMaxSuccess 10000 $ prop_wellBalanced
+            property $ withMaxSuccess 10_000 $ prop_wellBalanced
                 @(Wrapped TxIn) @Address
 
     describe "selectCoins regressions" $ do
@@ -177,18 +178,18 @@ prop_onlyChangeOutputs feeOpts batchSize utxo = do
             coinMapToList . outputs =<< selectCoins feeOpts batchSize utxo
     property (allOutputs `shouldSatisfy` null)
 
--- | Every coin in the selection change >= minimum threshold coin
-prop_noLessThanThreshold
+-- | Every coin in the selection change > dust threshold
+prop_allAboveThreshold
     :: forall i o . (Ord i, Ord o)
     => FeeOptions i o
     -> BatchSize
     -> CoinMap i
     -> Property
-prop_noLessThanThreshold feeOpts batchSize utxo = do
+prop_allAboveThreshold feeOpts batchSize utxo = do
     let allChange = change
             =<< selectCoins feeOpts batchSize utxo
     let undersizedCoins =
-            filter (< threshold) allChange
+            filter (<= threshold) allChange
     property (undersizedCoins `shouldSatisfy` null)
   where
     threshold = unDustThreshold $ dustThreshold feeOpts