takeEvents (#142)

* takeEvents

* spago update

* abstract over container

* pin web3

example/contracts/SimplePaidStorage.sol

@@ -31,14 +31,14 @@ contract SimplePaidStorage {
             "Token allowance not set for contract"
         );
 
-        _token.transferFrom(msg.sender, _owner, 1);
+        _token.transferFrom(msg.sender, address(this), 1);
 
         count = _newCount;
         emit CountUpdated(_newCount);
     }
 
-    // In case the owner wants to withdraw tokens
-    function withdrawTokens(uint amount) external onlyOwner {
+    // withdraw tokens to owner, pay the sender a fee
+    function withdrawTokens(uint amount) public onlyOwner {
         _token.transfer(_owner, amount);
     }
 }

example/test/SimplePaidStorageSpec.purs

@@ -2,18 +2,22 @@ module Test.SimplePaidStorageSpec where
 
 import Prelude
 
-import Chanterelle.Test (assertWeb3, takeEvent)
+import Chanterelle.Test (assertWeb3, takeEvent, takeEvents)
 import Contract.SimplePaidStorage as SPS
 import Contract.Token as Token
 import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Parallel (parTraverse_)
 import Data.Array (length, zip, (..))
+import Data.Array.Partial as Array
 import Data.Either (Either(..))
 import Data.Lens ((?~))
+import Data.Maybe (fromJust)
+import Data.Maybe.First (First(..))
+import Data.Newtype (un)
 import Data.Tuple (Tuple(..))
 import Effect.Aff (Aff)
 import Network.Ethereum.Web3 (Address, ChainCursor(..), Web3Error, _from, _to, defaultTransactionOptions, fromInt, runWeb3, unUIntN)
-import Partial.Unsafe (unsafeCrashWith)
+import Partial.Unsafe (unsafeCrashWith, unsafePartial)
 import Test.Common (DeploySpecConfig, unsafeToUInt)
 import Test.Spec (SpecT, beforeAll_, describe, it)
 import Test.Spec.Assertions (shouldEqual)
@@ -58,10 +62,19 @@ spec testCfg =
                 # _from ?~ account
                 # _to ?~ testCfg.simplePaidStorage
               tx = SPS.updateCount txOpts { _newCount: n }
-            Tuple _ (SPS.CountUpdated { newCount }) <- assertWeb3 testCfg.provider $
-              takeEvent (Proxy @SPS.CountUpdated) testCfg.simplePaidStorage tx
+
+            Tuple _ { countUpdated, transfer } <- assertWeb3 testCfg.provider $
+              takeEvents tx
+                { countUpdated: Tuple (Proxy @SPS.CountUpdated) testCfg.simplePaidStorage
+                , transfer: Tuple (Proxy @Token.Transfer) testCfg.token
+                }
+            let SPS.CountUpdated { newCount } = unsafePartial $ Array.head countUpdated
             -- check that the new count is the one we submitted
             newCount `shouldEqual` n
+            let Token.Transfer { to, from, value } = unsafePartial $ fromJust $ un First transfer
+            from `shouldEqual` account
+            to `shouldEqual` testCfg.simplePaidStorage
+            unUIntN value `shouldEqual` one
 
       it "The owner of the SimplePaidStorage can collect the tokens" $ do
         let
@@ -85,14 +98,15 @@ spec testCfg =
             in
               SPS.withdrawTokens txOpts { amount: contractBalance }
         -- withdraw tokens and wait for event confirmation
-        (Tuple _ e) <- assertWeb3 testCfg.provider $
+        Tuple _ (Token.Transfer { to, from, value }) <- assertWeb3 testCfg.provider $
           takeEvent (Proxy @Token.Transfer) testCfg.token fetchTokens
-        let Token.Transfer { from, to, value } = e
-        -- check that the transfer passes the sanity check
+
         from `shouldEqual` testCfg.simplePaidStorage
         to `shouldEqual` testCfg.simplePaidStorageOwner
-        value `shouldEqual` contractBalance
-        -- check that tokens are not created or destroyed
+        let n = unUIntN value
+        n `shouldEqual` unUIntN contractBalance
+
+        -- check that tokens are not created or destroyed (accounting for fees)
         { contractBalance: newContractBalance, ownerBalance: newOwnerBalance } <- fetchBalances
         unUIntN newContractBalance `shouldEqual` zero
         unUIntN newOwnerBalance `shouldEqual` (unUIntN ownerBalance + unUIntN contractBalance)

packages.dhall

@@ -2,7 +2,7 @@ let upstream =
       https://raw.githubusercontent.com/f-o-a-m/package-sets/b3ecf8e8e4e1a35ba97fcb7e9f2858d14ee6a912/purs-0.15.7-web3.dhall
         sha256:ce57fd949b7cd331d7c61ff45283e35983dd5797b3f17616dd69f8bc06f54784
     with eth-core.version = "v10.0.0"
-    with web3.version = "v6.1.0"
+    with web3.version = "v6.2.0"
 
 let overrides = {=}
 

spago.dhall

@@ -44,6 +44,7 @@ You can edit this file as you like.
   , "profunctor-lenses"
   , "record"
   , "refs"
+  , "simple-json"
   , "solc"
   , "strings"
   , "transformers"

src/Chanterelle/Deploy.purs

@@ -18,10 +18,10 @@ import Chanterelle.Types.Bytecode (Bytecode(..))
 import Chanterelle.Types.Bytecode as CBC
 import Chanterelle.Types.Deploy (DeployM, runDeployM, ContractConfig, DeployConfig(..), DeployError(..), LibraryConfig, NetworkID)
 import Chanterelle.Utils (getNetworkID, getPrimaryAccount, pollTransactionReceipt, withExceptT', makeProvider)
+import Chanterelle.Utils.Web3 (attemptWithTimeout)
 import Control.Monad.Error.Class (class MonadThrow)
 import Control.Monad.Except (runExceptT)
 import Control.Monad.Reader.Class (class MonadAsk, ask)
-import Control.Parallel (parOneOf)
 import Data.Bifunctor (lmap)
 import Data.Either (Either(..), either)
 import Data.Int (toNumber)
@@ -30,7 +30,7 @@ import Data.Map as Map
 import Data.Maybe (fromMaybe, isNothing, maybe)
 import Data.Time.Duration (Milliseconds(..))
 import Data.Validation.Semigroup (validation)
-import Effect.Aff (Aff, Error, attempt, delay, throwError)
+import Effect.Aff (Aff, attempt, throwError)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (liftEffect)
 import Effect.Exception (error, throw)
@@ -132,7 +132,7 @@ getPublishedContractDeployInfo txHash name (ArtifactBytecode { bytecode, deploye
   log Info $ "Polling for " <> name <> " transaction receipt: " <> show txHash
   let txReceiptError err = OnDeploymentError { name, message: "Failed to get transaction receipt: " <> show err }
   TransactionReceipt txReceipt <- do
-    eRes <- liftAff $ attemptWithTimeout timeout (pollTransactionReceipt txHash provider)
+    eRes <- liftAff $ attempt $ attemptWithTimeout timeout (pollTransactionReceipt txHash provider)
     either (throwError <<< txReceiptError) pure eRes
   if txReceipt.status == Failed || isNothing (txReceipt.contractAddress) then
     let
@@ -367,15 +367,3 @@ validateDeployArgs cfg =
     onSucc = pure
   in
     validation onErr onSucc cfg.unvalidatedArgs
-
--- | try an aff action for the specified amount of time before giving up.
-attemptWithTimeout
-  :: forall a
-   . Milliseconds
-  -> Aff a
-  -> Aff (Either Error a)
-attemptWithTimeout t action = attempt $
-  let
-    timeout = delay t *> throwError (error "timed out")
-  in
-    parOneOf [ action, timeout ]

src/Chanterelle/Test.purs

@@ -1,5 +1,10 @@
 module Chanterelle.Test
   ( takeEvent
+  , takeEvents
+  , class TakeEvents
+  , takeEventsBuilder
+  , class JoinEvents
+  , joinEventsBuilder
   , assertWeb3
   , TestConfig
   , TestConfigR
@@ -11,51 +16,179 @@ import Prelude
 import Chanterelle.Deploy (makeDeployConfig)
 import Chanterelle.Logging (logDeployError)
 import Chanterelle.Types.Deploy (DeployConfig(..), DeployError(..), DeployM, runDeployM)
+import Chanterelle.Utils (pollTransactionReceipt)
 import Control.Monad.Error.Class (throwError)
 import Control.Monad.Except (runExceptT)
 import Control.Monad.Reader (ask)
+import Data.Array.Partial as Array
 import Data.Either (Either(..), either)
+import Data.Lens ((.~))
+import Data.Symbol (class IsSymbol)
 import Data.Tuple (Tuple(..))
-import Effect.Aff (Aff)
+import Effect.Aff (Aff, Fiber, error, joinFiber)
 import Effect.Aff.AVar as AVar
 import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 import Effect.Exception (throw)
-import Network.Ethereum.Web3 (class EventFilter, Address, Change(..), EventAction(..), HexString, Provider, Web3, event, eventFilter, forkWeb3', runWeb3)
+import Network.Ethereum.Web3 (class EventFilter, Address, BlockNumber, ChainCursor(..), Change(..), EventAction(..), Filter, HexString, Provider, TransactionReceipt(..), TransactionStatus(..), Web3, Web3Error, _fromBlock, _toBlock, event, eventFilter, forkWeb3', runWeb3, throwWeb3, unHex)
 import Network.Ethereum.Web3.Api (eth_getAccounts)
 import Network.Ethereum.Web3.Solidity (class DecodeEvent)
-import Partial.Unsafe (unsafeCrashWith)
+import Partial.Unsafe (unsafeCrashWith, unsafePartial)
 import Prim.Row as Row
-import Record.Builder (build, merge)
-import Type.Proxy (Proxy)
+import Prim.RowList as RL
+import Record as R
+import Record.Builder (Builder, build, merge)
+import Record.Builder as Builder
+import Simple.JSON (writeJSON)
+import Type.Proxy (Proxy(..))
 
 -- | Run a transaction which will dispatch a single event, wait for the event,
 -- | then return the txHash and the event. NB: It will return the first event
 -- | from the given contract caused by the transaction.
 takeEvent
   :: forall ev i ni
    . DecodeEvent i ni ev
-  => Show ev
   => EventFilter ev
   => Proxy ev
   -> Address
   -> Web3 HexString
   -> Web3 (Tuple HexString ev)
-takeEvent prx addrs web3Action = do
-  var <- liftAff AVar.empty
-  txHashVar <- liftAff AVar.empty
-  _ <- forkWeb3' do
-    event (eventFilter prx addrs) $ \e -> do
-      txHash <- liftAff $ AVar.read txHashVar
-      Change { transactionHash } <- ask
-      if txHash == transactionHash then do
-        liftAff $ AVar.put e var
-        pure TerminateEvent
-      else pure ContinueEvent
+takeEvent p addr web3Action = do
   txHash <- web3Action
-  liftAff $ AVar.put txHash txHashVar
-  ev <- liftAff $ AVar.take var
-  pure $ Tuple txHash ev
+  provider <- ask
+  TransactionReceipt { blockNumber, status } <- liftAff $ pollTransactionReceipt txHash provider
+  unless (status == Succeeded)
+    $ throwError
+    $ error
+    $ "transaction failed: " <> unHex txHash
+  let
+    filter = eventFilter p addr
+      # _fromBlock .~ BN blockNumber
+      # _toBlock .~ BN blockNumber
+  fiber <- hashMonitor txHash filter
+  res <- liftAff $ joinFiber fiber
+  case res of
+    Left e -> throwError (error $ writeJSON e)
+    Right as ->
+      let
+        a = unsafePartial $ Array.head as
+      in
+        pure (Tuple txHash a)
+
+data MonitorStatus = Waiting | Active
+
+derive instance Eq MonitorStatus
+
+hashMonitor
+  :: forall ev i ni f
+   . DecodeEvent i ni ev
+  => Applicative f
+  => Monoid (f ev)
+  => HexString
+  -> Filter ev
+  -> Web3 (Fiber (Either Web3Error (f ev)))
+hashMonitor txHash filter = do
+  eventsVar <- liftAff $ AVar.new mempty
+  statusVar <- liftAff $ AVar.new Waiting
+  let
+    handler = \e -> do
+      Change { transactionHash } <- ask
+      if txHash == transactionHash then liftAff do
+        evs <- AVar.take eventsVar
+        AVar.put (evs <> pure e) eventsVar
+        _ <- AVar.take statusVar
+        AVar.put Active statusVar
+        pure ContinueEvent
+      else liftAff do
+        status <- AVar.read statusVar
+        case status of
+          Active -> pure TerminateEvent
+          Waiting -> pure ContinueEvent
+  forkWeb3' do
+    _ <- event filter handler
+    liftAff do
+      ev <- AVar.read eventsVar
+      AVar.kill (error "clean up statusVar") statusVar
+      AVar.kill (error "clean up eventsVar") eventsVar
+      pure ev
+
+takeEvents
+  :: forall row xs row' events
+   . RL.RowToList row xs
+  => TakeEvents xs row () row'
+  => JoinEvents xs row' () events
+  => Web3 HexString
+  -> Record row
+  -> Web3 (Tuple HexString (Record events))
+takeEvents tx r = do
+  txHash <- tx
+  provider <- ask
+  TransactionReceipt { blockNumber } <- liftAff $ pollTransactionReceipt txHash provider
+  fibersBuilder <- takeEventsBuilder (Proxy :: _ xs) (Tuple txHash blockNumber) r
+  let fibers = Builder.build fibersBuilder {}
+  eventsBuilder <- joinEventsBuilder (Proxy :: _ xs) fibers
+  pure $ Tuple txHash $ Builder.build eventsBuilder {}
+
+class
+  TakeEvents (xs :: RL.RowList Type) (row :: Row Type) (from :: Row Type) (to :: Row Type)
+  | xs -> row from to where
+  takeEventsBuilder :: Proxy xs -> Tuple HexString BlockNumber -> Record row -> Web3 (Builder { | from } { | to })
+
+instance TakeEvents RL.Nil row () () where
+  takeEventsBuilder _ _ _ = pure (identity)
+
+instance
+  ( DecodeEvent i ni ev
+  , Applicative f
+  , Monoid (f ev)
+  , EventFilter ev
+  , IsSymbol name
+  , Row.Cons name (Tuple (Proxy ev) Address) trash row
+  , TakeEvents tail row from from'
+  , Row.Lacks name from'
+  , Row.Cons name (Fiber (Either Web3Error (f ev))) from' to
+  ) =>
+  TakeEvents (RL.Cons name (Tuple (Proxy ev) Address) tail) row from to where
+  takeEventsBuilder _ a@(Tuple txHash blockNumber) r = do
+    let
+      nameP = Proxy :: _ name
+      Tuple p addr = R.get nameP r :: Tuple (Proxy ev) Address
+      filter = eventFilter p addr
+        # _fromBlock .~ BN blockNumber
+        # _toBlock .~ BN blockNumber
+    fiber <- hashMonitor txHash filter
+    let first = Builder.insert nameP fiber
+    rest <- takeEventsBuilder (Proxy :: _ tail) a r
+    pure (first <<< rest)
+
+class
+  JoinEvents (xs :: RL.RowList Type) (row :: Row Type) (from :: Row Type) (to :: Row Type)
+  | xs -> row from to where
+  joinEventsBuilder :: Proxy xs -> Record row -> Web3 (Builder { | from } { | to })
+
+instance JoinEvents RL.Nil row () () where
+  joinEventsBuilder _ _ = pure identity
+
+instance
+  ( DecodeEvent i ni ev
+  , IsSymbol name
+  , Row.Cons name (Fiber (Either Web3Error (f ev))) trash row
+  , JoinEvents tail row from from'
+  , Row.Lacks name from'
+  , Row.Cons name (f ev) from' to
+  ) =>
+  JoinEvents (RL.Cons name (Tuple (Proxy ev) Address) tail) row from to where
+  joinEventsBuilder _ r = do
+    let
+      nameP = Proxy :: _ name
+      fiber = R.get nameP r :: Fiber (Either Web3Error (f ev))
+    a <- liftAff (joinFiber fiber) >>= case _ of
+      -- This is a hack and relies on the internals of ps-web3.
+      Left e -> throwWeb3 e
+      Right a -> pure a
+    let first = Builder.insert nameP a
+    rest <- joinEventsBuilder (Proxy :: _ tail) r
+    pure (first <<< rest)
 
 -- | Assert the `Web3` action's result, crash the program if it doesn't succeed.
 assertWeb3