wallet-api: Property tests for coin selection

wallet-api/src/Wallet/Emulator/Types.hs

@@ -58,7 +58,8 @@ module Wallet.Emulator.Types(
     evalEmulated,
     processEmulated,
     runWalletActionAndProcessPending,
-    fundsDistribution
+    fundsDistribution,
+    selectCoin
     ) where
 
 import           Control.Lens               hiding (index)
@@ -81,8 +82,7 @@ import           Servant.API                (FromHttpApiData, ToHttpApiData)
 
 import           Data.Hashable              (Hashable)
 import           Ledger                     (Address', Block, Blockchain, Height, Tx (..), TxId', TxOutRef', Value,
-                                             hashTx, height, pubKeyAddress, pubKeyTxIn, pubKeyTxOut, txOutAddress,
-                                             txOutValue)
+                                             hashTx, height, pubKeyAddress, pubKeyTxIn, pubKeyTxOut, txOutAddress)
 import qualified Ledger.Index               as Index
 import           Wallet.API                 (EventHandler (..), EventTrigger, KeyPair (..), WalletAPI (..),
                                              WalletAPIError (..), WalletDiagnostics (..), WalletLog (..), addresses,
@@ -204,24 +204,14 @@ instance WalletAPI MockWallet where
 
     createPaymentWithChange vl = do
         ws <- get
-        let fnds  = ws ^. ownFunds
-            total = getSum $ foldMap Sum fnds
+        let fnds = ws ^. ownFunds
             kp    = view ownKeyPair ws
             sig   = signature kp
-            err   = throwError $ InsufficientFunds $ T.unwords ["Total:", T.pack $ show total, "expected:", T.pack $ show vl]
-        case Map.toList fnds of
-            []   -> err
-            x:xs
-                | total < vl -> err
-                | otherwise  ->
-                    let fundsWithTotal = P.zip (x:xs) (drop 1 $ P.scanl (+) 0 $ fmap snd (x:xs))
-                        fundsToSpend   = takeUntil (\(_, runningTotal) -> vl >= runningTotal) fundsWithTotal
-                        txIns          = Set.fromList (flip pubKeyTxIn sig . fst . fst <$> fundsToSpend)
-                        totalSpent     = P.last (snd <$> fundsToSpend)-- can use `last` because `fundsToSpend` is not empty
-                        change         = totalSpent - vl -- `change` is the value that we pay back to a public-key address owned by us
-                        txOutput       = pubKeyTxOut change (pubKey kp)
-                        txOutput'      = if txOutValue txOutput == 0 then Nothing else Just txOutput
-                    in pure (txIns, txOutput')
+        (spend, change) <- selectCoin (Map.toList fnds) vl
+        let
+            txOutput = if change > 0 then Just (pubKeyTxOut change (pubKey kp)) else Nothing
+            ins = Set.fromList (flip pubKeyTxIn sig . fst <$> spend)
+        pure (ins, txOutput)
 
     register tr action =
         modify (over triggers (Map.insertWith (<>) tr action))
@@ -233,6 +223,32 @@ instance WalletAPI MockWallet where
 
     blockHeight = use walletBlockHeight
 
+-- | Given a set of 'a's with coin values, and a target value, select a number
+-- of 'a' such that their total value is greater than or equal to the target.
+selectCoin :: (MonadError WalletAPIError m)
+    => [(a, Value)]
+    -> Value
+    -> m ([(a, Value)], Value)
+selectCoin fnds vl =
+        let
+            total = getSum $ foldMap (Sum . snd) fnds
+            fundsWithTotal = P.zip fnds (drop 1 $ P.scanl (+) 0 $ fmap snd fnds)
+            err   = throwError
+                    $ InsufficientFunds
+                    $ T.unwords
+                        [ "Total:", T.pack $ show total
+                        , "expected:", T.pack $ show vl]
+        in  if total < vl
+            then err
+            else
+                let
+                    fundsToSpend   = takeUntil (\(_, runningTotal) -> vl <= runningTotal) fundsWithTotal
+                    totalSpent     = case reverse fundsToSpend of
+                                        []            -> 0
+                                        (_, total'):_ -> total'
+                    change         = totalSpent - vl
+                in pure (fst <$> fundsToSpend, change)
+
 -- | Take elements from a list until the predicate is satisfied.
 --   'takeUntil' @p@ includes the first element for wich @p@ is true
 --   (unlike @takeWhile (not . p)@).

wallet-api/src/Wallet/Generators.hs

@@ -18,6 +18,7 @@ module Wallet.Generators(
     -- * Assertions
     assertValid,
     -- * Etc.
+    genValue,
     Wallet.Generators.runTrace,
     runTraceOn,
     splitVal
@@ -166,6 +167,9 @@ genValidTransactionSpending' g f ins totalVal = do
                     txSignatures = [] }
         else Gen.discard
 
+genValue :: MonadGen m => m Value
+genValue = Value <$> Gen.int (Range.linear 0 (100000 :: Int))
+
 -- | Assert that a transaction is valid in a chain
 assertValid :: (MonadTest m, HasCallStack)
     => Tx

wallet-api/test/Spec.hs

@@ -6,6 +6,7 @@ module Main(main) where
 
 import           Control.Lens
 import           Control.Monad              (void)
+import           Control.Monad.Trans.Except (runExcept)
 import           Data.Either                (isLeft, isRight)
 import           Data.Foldable              (traverse_)
 import qualified Data.Map                   as Map
@@ -49,10 +50,12 @@ tests = testGroup "all tests" [
         testProperty "react to blockchain events" eventTrace,
         testProperty "watch funds at an address" notifyWallet,
         testProperty "log script validation failures" invalidScript,
-        testProperty "payToPubkey" payToPubKeyScript
+        testProperty "payToPubkey" payToPubKeyScript,
+        testProperty "payToPubkey-2" payToPubKeyScript2
         ],
     testGroup "Etc." [
-        testProperty "splitVal" splitVal
+        testProperty "splitVal" splitVal,
+        testProperty "selectCoin" selectCoinProp
         ]
     ]
 
@@ -155,6 +158,17 @@ splitVal = property $ do
     Hedgehog.assert $ sum vs == i
     Hedgehog.assert $ length vs <= n
 
+selectCoinProp :: Property
+selectCoinProp = property $ do
+    inputs <- forAll $ zip [1..] <$> Gen.list (Range.linear 1 1000) Gen.genValue
+    target <- forAll Gen.genValue
+    let result = runExcept (selectCoin inputs target)
+    case result of
+        Left _ -> 
+            Hedgehog.assert $ (sum $ snd <$> inputs) < target
+        Right (ins, change) -> 
+            Hedgehog.assert $ (sum $ snd <$> ins) == target + change
+
 notifyWallet :: Property
 notifyWallet = property $ do
     let w = Wallet 1
@@ -188,6 +202,27 @@ eventTrace = property $ do
     -- if `mkPayment` was run then the funds of wallet 1 should be reduced by 100
     Hedgehog.assert $ (getSum . foldMap Sum . view ownFunds <$> ttl) == Just (initialBalance - 100)
 
+payToPubKeyScript2 :: Property
+payToPubKeyScript2 = property $ do
+    let [w1, w2, w3] = Wallet <$> [1, 2, 3]
+        updateAll = processPending >>= walletsNotifyBlock [w1, w2, w3]
+    (e, _) <- forAll
+        $ Gen.runTraceOn Gen.generatorModel
+        $ do
+            updateAll
+            walletAction (Wallet 1) $ payToPublicKey_ (initialBalance - 1) (PubKey 2)
+            updateAll 
+            walletAction (Wallet 2) $ payToPublicKey_ (initialBalance + 1) (PubKey 3)
+            updateAll
+            walletAction (Wallet 3) $ payToPublicKey_ (initialBalance + 1) (PubKey 1)
+            updateAll
+            walletAction (Wallet 1) $ payToPublicKey_ 2 (PubKey 2)
+            updateAll
+            traverse_ (uncurry assertOwnFundsEq) [
+                (w1, initialBalance),
+                (w2, initialBalance), 
+                (w3, initialBalance)]
+    Hedgehog.assert $ isRight e
 
 payToPubKeyScript :: Property
 payToPubKeyScript = property $ do

wallet-api/wallet-api.cabal

@@ -110,6 +110,7 @@ test-suite wallet-api-test
         hedgehog -any,
         tasty -any,
         tasty-hedgehog -any,
+        transformers -any,
         wallet-api -any,
         plutus-tx -any,
         plutus-tx-plugin -any,