Merge pull request #443 from input-output-hk/j-mueller/wallet-api-imp…

…rovements wallet-api: Improvements
IntersectMBO · Jan 3, 2019 · 92bc765 · 92bc765
2 parents 0005a81 + e10b2b9
commit 92bc765
Show file tree

Hide file tree

Showing 6 changed files with 43 additions and 30 deletions.
diff --git a/plutus-playground/plutus-playground-lib/src/Playground/Interpreter/Util.hs b/plutus-playground/plutus-playground-lib/src/Playground/Interpreter/Util.hs
@@ -11,7 +11,7 @@ import qualified Data.Map                   as Map
 import           Data.Monoid                (Sum (Sum), getSum)
 import qualified Data.Set                   as Set
 import qualified Data.Typeable              as T
-import           Ledger.Types               (Blockchain, PubKey (PubKey), Tx, Value (Value))
+import           Ledger.Types               (Blockchain, PubKey (PubKey), Tx, TxOut (txOutValue), Value (Value))
 import           Playground.API             (PlaygroundError (OtherError))
 import           Wallet.Emulator.Types      (EmulatorEvent, EmulatorState (_chainNewestFirst, _emulatorLog), MockWallet,
                                              Trace, Wallet (Wallet), ownFunds, processPending, runTraceTxPool,
@@ -43,7 +43,7 @@ runTrace wallets actions =
               blockchain = _chainNewestFirst newState
               emulatorLog = _emulatorLog newState
               fundsDistribution =
-                Map.map (getSum . foldMap Sum . view ownFunds) .
+                Map.map (getSum . foldMap (Sum . txOutValue) . view ownFunds) .
                 view walletStates $
                 newState
            in case eRes of

diff --git a/plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/CrowdFunding.hs b/plutus-use-cases/src/Language/PlutusTx/Coordination/Contracts/CrowdFunding.hs
@@ -89,7 +89,7 @@ collect cmp = register (collectFundsTrigger cmp) $ EventHandler $ \_ -> do
             red        = Ledger.RedeemerScript $ Ledger.lifted Collect
             con (r, _) = scriptTxIn r scr red
             ins        = con <$> contributions
-            value = getSum $ foldMap (Sum . snd) contributions
+            value = getSum $ foldMap (Sum . Ledger.txOutValue . snd) contributions
 
         oo <- ownPubKeyTxOut value
         void $ signAndSubmit (Set.fromList ins) [oo]
@@ -201,7 +201,7 @@ refund txid cmp = EventHandler $ \_ -> do
         red   = Ledger.RedeemerScript $ Ledger.lifted Refund
         i ref = scriptTxIn ref scr red
         inputs = Set.fromList $ i . fst <$> ourUtxo
-        value  = getSum $ foldMap (Sum . snd) ourUtxo
+        value  = getSum $ foldMap (Sum . Ledger.txOutValue . snd) ourUtxo
 
     out <- ownPubKeyTxOut value
     void $ signAndSubmit inputs [out]
diff --git a/wallet-api/src/Wallet/API.hs b/wallet-api/src/Wallet/API.hs
@@ -22,6 +22,8 @@ module Wallet.API(
     payToScript_,
     payToPublicKey,
     payToPublicKey_,
+    payToScripts,
+    payToScripts_,
     collectFromScript,
     collectFromScriptTxn,
     ownPubKeyTxOut,
@@ -275,13 +277,24 @@ throwOtherError = throwError . OtherError
 createPayment :: (Functor m, WalletAPI m) => Value -> m (Set.Set TxIn')
 createPayment vl = fst <$> createPaymentWithChange vl
 
+-- | Transfer some funds to a number of script addresses, returning the
+--   transaction that was submitted.
+payToScripts :: (Monad m, WalletAPI m) => [(Address', Value, DataScript)] -> m Tx
+payToScripts ins = do
+    let
+        totalVal     = getSum $ foldMap (Sum . view _2) ins
+        otherOutputs = fmap (\(addr, vl, ds) -> TxOut addr vl (PayToScript ds)) ins
+    (i, ownChange) <- createPaymentWithChange totalVal
+    signAndSubmit i (maybe otherOutputs (:otherOutputs) ownChange)
+
+-- | Transfer some funds to a number of script addresses.
+payToScripts_ :: (Monad m, WalletAPI m) => [(Address', Value, DataScript)] -> m ()
+payToScripts_ = void . payToScripts
+
 -- | Transfer some funds to an address locked by a script, returning the
 --   transaction that was submitted.
 payToScript :: (Monad m, WalletAPI m) => Address' -> Value -> DataScript -> m Tx
-payToScript addr v ds = do
-    (i, own) <- createPaymentWithChange v
-    let other = TxOut addr v (PayToScript ds)
-    signAndSubmit i (other : maybeToList own)
+payToScript addr v ds = payToScripts [(addr, v, ds)]
 
 -- | Transfer some funds to an address locked by a script.
 payToScript_ :: (Monad m, WalletAPI m) => Address' -> Value -> DataScript -> m ()
@@ -296,7 +309,7 @@ collectFromScript scr red = do
         outputs = am ^. at addr . to (Map.toList . fromMaybe Map.empty)
         con (r, _) = scriptTxIn r scr red
         ins        = con <$> outputs
-        value = getSum $ foldMap (Sum . snd) outputs
+        value = getSum $ foldMap (Sum . txOutValue . snd) outputs
 
     oo <- ownPubKeyTxOut value
     void $ signAndSubmit (Set.fromList ins) [oo]
@@ -312,7 +325,7 @@ collectFromScriptTxn vls red txid = do
         ourUtxo = Map.toList $ Map.filterWithKey (\k _ -> txid == Ledger.txOutRefId k) utxo
         i ref = scriptTxIn ref vls red
         inputs = Set.fromList $ i . fst <$> ourUtxo
-        value  = getSum $ foldMap (Sum . snd) ourUtxo
+        value  = getSum $ foldMap (Sum . txOutValue . snd) ourUtxo
 
     out <- ownPubKeyTxOut value
     void $ signAndSubmit inputs [out]

diff --git a/wallet-api/src/Wallet/Emulator/AddressMap.hs b/wallet-api/src/Wallet/Emulator/AddressMap.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeFamilies       #-}
 module Wallet.Emulator.AddressMap(
     AddressMap(..),
@@ -31,11 +30,11 @@ import qualified Data.Set               as Set
 import qualified Data.Text.Encoding     as TE
 import           GHC.Generics           (Generic)
 
-import           Ledger                 (Address', Tx (..), TxIn (..), TxIn', TxOut (..), TxOutRef (..), TxOutRef',
-                                         Value, hashTx)
+import           Ledger                 (Address', Tx (..), TxIn (..), TxIn', TxOut (..), TxOut', TxOutRef (..),
+                                         TxOutRef', Value, hashTx)
 
 -- | A map of [[Address']]es and their unspent outputs
-newtype AddressMap = AddressMap { getAddressMap :: Map Address' (Map TxOutRef' Value) }
+newtype AddressMap = AddressMap { getAddressMap :: Map Address' (Map TxOutRef' TxOut') }
     deriving Show
     deriving stock (Generic)
     deriving newtype (Serialise)
@@ -59,14 +58,14 @@ instance FromJSON AddressMap where
 
 instance Semigroup AddressMap where
     (AddressMap l) <> (AddressMap r) = AddressMap (Map.unionWith add l r) where
-        add = Map.unionWith (+)
+        add = Map.union
 
 instance Monoid AddressMap where
     mappend = (<>)
     mempty = AddressMap Map.empty
 
 type instance Index AddressMap = Address'
-type instance IxValue AddressMap = Map TxOutRef' Value
+type instance IxValue AddressMap = Map TxOutRef' TxOut'
 
 instance Ixed AddressMap where
     ix adr f (AddressMap mp) = AddressMap <$> ix adr f mp
@@ -80,7 +79,7 @@ instance At AddressMap where
 --   nothing.
 addAddress :: Address' -> AddressMap -> AddressMap
 addAddress adr (AddressMap mp) = AddressMap $ Map.alter upd adr mp where
-    upd :: Maybe (Map TxOutRef' Value) -> Maybe (Map TxOutRef' Value)
+    upd :: Maybe (Map TxOutRef' TxOut') -> Maybe (Map TxOutRef' TxOut')
     upd = maybe (Just Map.empty) Just
 
 -- | Add a list of [[Address']]es with no unspent outputs
@@ -89,20 +88,20 @@ addAddresses = flip (foldr addAddress)
 
 -- | The total value of unspent outputs at an address
 values :: AddressMap -> Map Address' Value
-values = Map.map (getSum . foldMap Sum) . getAddressMap
+values = Map.map (getSum . foldMap (Sum . txOutValue)) . getAddressMap
 
 -- | An [[AddressMap]] with the unspent outputs of a single transaction
 fromTxOutputs :: Tx -> AddressMap
 fromTxOutputs tx =
     AddressMap . Map.fromListWith Map.union . fmap mkUtxo . zip [0..] . txOutputs $ tx where
-    mkUtxo (i, TxOut{..}) = (txOutAddress, Map.singleton (TxOutRef h i) txOutValue)
+    mkUtxo (i, t) = (txOutAddress t, Map.singleton (TxOutRef h i) t)
     h = hashTx tx
 
 -- | A map of unspent transaction outputs to their addresses (the "inverse" of
 --   [[AddressMap]], without the values
 knownAddresses :: AddressMap -> Map TxOutRef' Address'
 knownAddresses = Map.fromList . unRef . Map.toList . getAddressMap where
-    unRef :: [(Address', Map TxOutRef' Value)] -> [(TxOutRef', Address')]
+    unRef :: [(Address', Map TxOutRef' TxOut')] -> [(TxOutRef', Address')]
     unRef lst = do
         (a, outRefs) <- lst
         (rf, _) <- Map.toList outRefs
@@ -118,7 +117,7 @@ updateAddresses tx utxo = AddressMap $ Map.mapWithKey upd (getAddressMap utxo) w
     upd adr mp = Map.union (producedAt adr) mp `Map.difference` consumedFrom adr
 
     -- The TxOutRefs produced by the transaction, for a given address
-    producedAt :: Address' -> Map TxOutRef' Value
+    producedAt :: Address' -> Map TxOutRef' TxOut'
     producedAt adr = Map.findWithDefault Map.empty adr outputs
 
     -- The TxOutRefs consumed by the transaction, for a given address

diff --git a/wallet-api/src/Wallet/Emulator/Types.hs b/wallet-api/src/Wallet/Emulator/Types.hs
@@ -81,8 +81,9 @@ import           Prelude                    as P
 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)
+import           Ledger                     (Address', Block, Blockchain, Height, Tx (..), TxId', TxOut (..), TxOut',
+                                             TxOutRef', Value, hashTx, height, pubKeyAddress, pubKeyTxIn, pubKeyTxOut,
+                                             txOutAddress)
 import qualified Ledger.Index               as Index
 import           Wallet.API                 (EventHandler (..), EventTrigger, KeyPair (..), WalletAPI (..),
                                              WalletAPIError (..), WalletDiagnostics (..), WalletLog (..), addresses,
@@ -135,7 +136,7 @@ makeLenses ''WalletState
 ownAddress :: WalletState -> Address'
 ownAddress = pubKeyAddress . pubKey . view ownKeyPair
 
-ownFunds :: Lens' WalletState (Map TxOutRef' Value)
+ownFunds :: Lens' WalletState (Map TxOutRef' TxOut')
 ownFunds = lens g s where
     g ws = fromMaybe Map.empty $ ws ^. addressMap . at (ownAddress ws)
     s ws utxo = ws & addressMap . at (ownAddress ws) ?~ utxo
@@ -207,7 +208,7 @@ instance WalletAPI MockWallet where
         let fnds = ws ^. ownFunds
             kp    = view ownKeyPair ws
             sig   = signature kp
-        (spend, change) <- selectCoin (Map.toList fnds) vl
+        (spend, change) <- selectCoin (second txOutValue <$> 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)
@@ -296,7 +297,7 @@ data EmulatorState = EmulatorState {
 makeLenses ''EmulatorState
 
 fundsDistribution :: EmulatorState -> Map Wallet Value
-fundsDistribution = Map.map (getSum . foldMap Sum . view ownFunds) . view walletStates
+fundsDistribution = Map.map (getSum . foldMap (Sum . txOutValue) . view ownFunds) . view walletStates
 
 -- | The blockchain as a list of blocks, starting with the oldest (genesis)
 --   block
@@ -324,7 +325,7 @@ ownFundsEqual wallet value = do
     ws <- case Map.lookup wallet $ _walletStates es of
         Nothing -> throwError $ AssertionError "Wallet not found"
         Just ws -> pure ws
-    let total = getSum $ foldMap Sum $ ws ^. ownFunds
+    let total = getSum $ foldMap (Sum . txOutValue) $ ws ^. ownFunds
     if value == total
     then pure ()
     else throwError . AssertionError $ T.unwords ["Funds in wallet", tshow wallet, "were", tshow total, ". Expected:", tshow value]

diff --git a/wallet-api/test/Spec.hs b/wallet-api/test/Spec.hs
@@ -188,7 +188,7 @@ notifyWallet = property $ do
         $ Gen.runTraceOn Gen.generatorModel
         $ processPending >>= walletNotifyBlock w
     let ttl = Map.lookup w st
-    Hedgehog.assert $ (getSum . foldMap Sum . view ownFunds <$> ttl) == Just initialBalance
+    Hedgehog.assert $ (getSum . foldMap (Sum . txOutValue) . view ownFunds <$> ttl) == Just initialBalance
 
 eventTrace :: Property
 eventTrace = property $ do
@@ -212,7 +212,7 @@ eventTrace = property $ do
     let ttl = Map.lookup w st
 
     -- 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)
+    Hedgehog.assert $ (getSum . foldMap (Sum . txOutValue) . view ownFunds <$> ttl) == Just (initialBalance - 100)
 
 payToPubKeyScript2 :: Property
 payToPubKeyScript2 = property $ do
@@ -279,7 +279,7 @@ watchFundsAtAddress = property $ do
             addBlocks 3 >>= traverse_ (walletNotifyBlock w)
             void (processPending >>= walletNotifyBlock w)
     let ttl = Map.lookup w st
-    Hedgehog.assert $ (getSum . foldMap Sum . view ownFunds <$> ttl) == Just (initialBalance - 200)
+    Hedgehog.assert $ (getSum . foldMap (Sum . txOutValue) . view ownFunds <$> ttl) == Just (initialBalance - 200)
 
 genChainTxn :: Hedgehog.MonadGen m => m (Mockchain, Tx)
 genChainTxn = do