Permalink
Browse files

Merge remote-tracking branch 'origin/master' into playground-test

  • Loading branch information...
David Smith
David Smith committed Dec 6, 2018
2 parents a88aae1 + 32b861a commit 564dbe72ef4cf647c35d201423053cee1741e121
@@ -66,8 +66,8 @@ module Joined where
-- The encoding technique described in this module is fairly well-known.
module JoinedCompute where
-- If an index of a data type is something that can be matched on, then we can turn it into a
-- parameter using induction-recursion.
-- In this section we'll make `TreeForest` a data type with a single constructor,
-- the contents of which depends on the type being constructed.
data TreeForestᵗ : Set where
Treeᵗ Forestᵗ : TreeForestᵗ
@@ -81,7 +81,6 @@ module JoinedCompute where
Forest : Set -> Set
Forest A = TreeForest A Forestᵗ
-- However the two definitions below are indeed mutual.
-- `TreeForestF` matches on the `TreeForestᵗ` index in order to figure out which data type
-- from the original family is being constructed.
-- Like in the previous section `TreeForest` defines both the `Tree` and `Forest` data types,
@@ -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 564dbe7

Please sign in to comment.