Permalink
Browse files

Merge pull request #382 from input-output-hk/j-mueller/pay-to-pubkey

wallet-api: Fix bug in coin selection
  • Loading branch information...
michaelpj committed Dec 6, 2018
2 parents 1b7f38b + 29c1c80 commit 32b861a809f061b00ad2c210ee9a65d3cb8b87f5
Showing with 48 additions and 19 deletions.
  1. +25 −18 wallet-api/src/Wallet/Emulator/Types.hs
  2. +23 −1 wallet-api/test/Spec.hs
@@ -61,7 +61,7 @@ module Wallet.Emulator.Types(
fundsDistribution
) where
import Control.Lens hiding (index, uncons)
import Control.Lens hiding (index)
import Control.Monad.Except
import Control.Monad.Operational as Op hiding (view)
import Control.Monad.State
@@ -70,7 +70,6 @@ import Control.Newtype.Generics (Newtype)
import Data.Aeson (FromJSON, ToJSON, ToJSONKey)
import Data.Bifunctor (Bifunctor (..))
import Data.Foldable (traverse_)
import Data.List (uncons)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
@@ -204,24 +203,23 @@ instance WalletAPI MockWallet where
createPaymentWithChange vl = do
ws <- get
let fnds = ws ^. ownFunds
let fnds = ws ^. ownFunds
total = getSum $ foldMap Sum fnds
kp = view ownKeyPair ws
kp = view ownKeyPair ws
sig = signature kp
if total < vl || Map.null fnds
then throwError $ InsufficientFunds $ T.unwords ["Total:", T.pack $ show total, "expected:", T.pack $ show vl]
else
-- This is the coin selection algorithm
-- TODO: Should be customisable
let funds = P.takeWhile ((vl <) . snd)
$ maybe [] (uncurry (P.scanl (\t v -> second (+ snd v) t)))
$ uncons
$ Map.toList fnds
ins = Set.fromList (flip pubKeyTxIn sig . fst <$> funds)
diff = maximum (snd <$> funds) - vl
out = pubKeyTxOut diff (pubKey kp) in
pure (ins, out)
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)
in pure (txIns, txOutput)
register tr action =
modify (over triggers (Map.insertWith (<>) tr action))
@@ -233,6 +231,15 @@ instance WalletAPI MockWallet where
blockHeight = use walletBlockHeight
-- | 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)@).
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil _ [] = []
takeUntil p (x:xs)
| p x = [x]
| otherwise = x : takeUntil p xs
-- Emulator code
data Assertion
@@ -48,7 +48,8 @@ tests = testGroup "all tests" [
testProperty "notify wallet" notifyWallet,
testProperty "react to blockchain events" eventTrace,
testProperty "watch funds at an address" notifyWallet,
testProperty "log script validation failures" invalidScript
testProperty "log script validation failures" invalidScript,
testProperty "payToPubkey" payToPubKeyScript
],
testGroup "Etc." [
testProperty "splitVal" splitVal
@@ -187,6 +188,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)
payToPubKeyScript :: Property
payToPubKeyScript = 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) $ void $ payToPubKey 5 (PubKey 2)
updateAll
walletAction (Wallet 2) $ void $ payToPubKey 5 (PubKey 3)
updateAll
walletAction (Wallet 3) $ void $ payToPubKey 5 (PubKey 1)
updateAll
traverse_ (uncurry assertOwnFundsEq) [
(w1, 100000),
(w2, 100000),
(w3, 100000)]
Hedgehog.assert $ isRight e
watchFundsAtAddress :: Property
watchFundsAtAddress = property $ do
let w = Wallet 1

0 comments on commit 32b861a

Please sign in to comment.