abstract over container

example/contracts/SimplePaidStorage.sol

@@ -10,7 +10,6 @@ contract SimplePaidStorage {
     uint public count = 0;
 
     event CountUpdated(uint newCount);
-    event TokensWithdrawn(uint amount);
 
     constructor(address tokenAddress) {
         _token = IERC20(tokenAddress);
@@ -32,15 +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);
-        emit TokensWithdrawn(amount);
     }
 }

example/test/SimplePaidStorageSpec.purs

@@ -8,12 +8,13 @@ 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.Tuple (Tuple(..))
 import Effect.Aff (Aff)
-import Network.Ethereum.Web3 (Address, ChainCursor(..), Web3Error, _from, _to, defaultTransactionOptions, eventFilter, fromInt, runWeb3, unUIntN)
-import Partial.Unsafe (unsafeCrashWith)
+import Network.Ethereum.Web3 (Address, ChainCursor(..), Web3Error, _from, _to, defaultTransactionOptions, fromInt, runWeb3, unUIntN)
+import Partial.Unsafe (unsafeCrashWith, unsafePartial)
 import Test.Common (DeploySpecConfig, unsafeToUInt)
 import Test.Spec (SpecT, beforeAll_, describe, it)
 import Test.Spec.Assertions (shouldEqual)
@@ -58,10 +59,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 $ Array.head 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,19 +95,15 @@ spec testCfg =
             in
               SPS.withdrawTokens txOpts { amount: contractBalance }
         -- withdraw tokens and wait for event confirmation
-        { withdrawn, transfer } <- assertWeb3 testCfg.provider $
-          takeEvents fetchTokens
-            { withdrawn: eventFilter (Proxy @SPS.TokensWithdrawn) testCfg.simplePaidStorage
-            , transfer: eventFilter (Proxy @Token.Transfer) testCfg.token
-            }
-        let Token.Transfer { from, to, value } = transfer
-        let SPS.TokensWithdrawn { amount } = withdrawn
-        -- check that the transfer passes the sanity check
+        Tuple _ (Token.Transfer { to, from, value }) <- assertWeb3 testCfg.provider $
+          takeEvent (Proxy @Token.Transfer) testCfg.token fetchTokens
+
         from `shouldEqual` testCfg.simplePaidStorage
         to `shouldEqual` testCfg.simplePaidStorageOwner
-        value `shouldEqual` contractBalance
-        amount `shouldEqual` value
-        -- 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)

spago.dhall

@@ -43,7 +43,6 @@ You can edit this file as you like.
   , "prelude"
   , "profunctor-lenses"
   , "record"
-  , "record-extra"
   , "refs"
   , "simple-json"
   , "solc"

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

@@ -16,22 +16,24 @@ 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, Fiber, error, joinFiber)
-import Effect.Aff.AVar (AVar)
 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(..), Filter, HexString, Provider, Web3, Web3Error, 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, 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 Prim.RowList as RL
 import Record as R
@@ -52,33 +54,63 @@ takeEvent
   -> Web3 HexString
   -> Web3 (Tuple HexString ev)
 takeEvent p addr web3Action = do
-  txHashVar <- liftAff AVar.empty
-  let filter = eventFilter p addr
-  fiber <- hashMonitor txHashVar filter
   txHash <- web3Action
-  liftAff $ AVar.put txHash txHashVar
+  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 a -> pure (Tuple txHash a)
+    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
+  :: forall ev i ni f
    . DecodeEvent i ni ev
-  => AVar HexString
+  => Applicative f
+  => Monoid (f ev)
+  => HexString
   -> Filter ev
-  -> Web3 (Fiber (Either Web3Error ev))
-hashMonitor txHashVar filter = do
-  var <- liftAff AVar.empty
+  -> Web3 (Fiber (Either Web3Error (f ev)))
+hashMonitor txHash filter = do
+  eventsVar <- liftAff $ AVar.new mempty
+  statusVar <- liftAff $ AVar.new Waiting
   let
     handler = \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
-  forkWeb3' (event filter handler *> liftAff (AVar.take var))
+      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
@@ -87,38 +119,46 @@ takeEvents
   => JoinEvents xs row' () events
   => Web3 HexString
   -> Record row
-  -> Web3 (Record events)
+  -> Web3 (Tuple HexString (Record events))
 takeEvents tx r = do
-  txHashVar <- liftAff $ AVar.empty
-  fibersBuilder <- takeEventsBuilder (Proxy :: _ xs) txHashVar r
-  let fibers = Builder.build fibersBuilder {}
   txHash <- tx
-  liftAff $ AVar.put txHash txHashVar
+  provider <- ask
+  TransactionReceipt { blockNumber } <- liftAff $ pollTransactionReceipt txHash provider
+  fibersBuilder <- takeEventsBuilder (Proxy :: _ xs) (Tuple txHash blockNumber) r
+  let fibers = Builder.build fibersBuilder {}
   eventsBuilder <- liftAff $ joinEventsBuilder (Proxy :: _ xs) fibers
-  pure $ Builder.build eventsBuilder {}
+  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 -> AVar HexString -> Record row -> Web3 (Builder { | from } { | to })
+  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 (Filter ev) trash row
+  , Row.Cons name (Tuple (Proxy ev) Address) trash row
   , TakeEvents tail row from from'
   , Row.Lacks name from'
-  , Row.Cons name (Fiber (Either Web3Error ev)) from' to
+  , Row.Cons name (Fiber (Either Web3Error (f ev))) from' to
   ) =>
-  TakeEvents (RL.Cons name (Filter ev) tail) row from to where
-  takeEventsBuilder _ txHash r = do
-    let nameP = Proxy :: _ name
-    fiber <- hashMonitor txHash (R.get nameP r :: Filter ev)
+  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) txHash r
+    rest <- takeEventsBuilder (Proxy :: _ tail) a r
     pure (first <<< rest)
 
 class
@@ -132,16 +172,16 @@ instance JoinEvents RL.Nil row () () where
 instance
   ( DecodeEvent i ni ev
   , IsSymbol name
-  , Row.Cons name (Fiber (Either Web3Error ev)) trash row
+  , Row.Cons name (Fiber (Either Web3Error (f ev))) trash row
   , JoinEvents tail row from from'
   , Row.Lacks name from'
-  , Row.Cons name ev from' to
+  , Row.Cons name (f ev) from' to
   ) =>
-  JoinEvents (RL.Cons name (Filter ev) tail) row from to where
+  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 ev)
+      fiber = R.get nameP r :: Fiber (Either Web3Error (f ev))
     a <- joinFiber fiber >>= case _ of
       -- This is a hack and relies on the internals of ps-web3.
       Left e -> throwError (error $ writeJSON e)

src/Chanterelle/Utils/Web3.purs

@@ -7,12 +7,13 @@ import Chanterelle.Types.Deploy (DeployError(..), NetworkID)
 import Chanterelle.Types.Project (Network(..), networkIDFitsChainSpec)
 import Control.Monad.Error.Class (class MonadThrow, throwError)
 import Control.Monad.Except (ExceptT(..), except, runExceptT, withExceptT)
+import Control.Parallel (parOneOf)
 import Data.Array (head)
 import Data.Either (Either(..))
 import Data.Int (fromString)
 import Data.Maybe (Maybe, maybe)
 import Data.String (null)
-import Effect.Aff (Milliseconds(..), delay)
+import Effect.Aff (Aff, Milliseconds(..), delay)
 import Effect.Aff.Class (class MonadAff, liftAff)
 import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Exception (Error, error, try)
@@ -116,15 +117,25 @@ getNetworkID = do
 -- | indefinitely poll for a transaction receipt, sleeping for 3
 -- | seconds in between every call.
 pollTransactionReceipt
-  :: forall m
-   . MonadAff m
-  => HexString
+  :: HexString
   -> Provider
-  -> m TransactionReceipt
+  -> Aff TransactionReceipt
 pollTransactionReceipt txHash provider = do
   etxReceipt <- liftAff <<< runWeb3 provider $ eth_getTransactionReceipt txHash
   case etxReceipt of
     Left _ -> do
-      liftAff $ delay (Milliseconds 3000.0)
+      delay (Milliseconds 1000.0)
       pollTransactionReceipt txHash provider
     Right txRec -> pure txRec
+
+-- | try an aff action for the specified amount of time before giving up.
+attemptWithTimeout
+  :: forall a
+   . Milliseconds
+  -> Aff a
+  -> Aff a
+attemptWithTimeout t action =
+  let
+    timeout = delay t *> throwError (error "timed out")
+  in
+    parOneOf [ action, timeout ]