Better event fetching code for e2e tests

src/Internal/Helpers.purs

@@ -1,15 +1,16 @@
 module Ctl.Internal.Helpers
   ( (</>)
+  , (<</>>)
   , (<<>>)
   , (<\>)
-  , (<</>>)
   , appendFirstMaybe
   , appendLastMaybe
   , appendMap
   , appendRightMap
   , bigIntToUInt
   , concatPaths
   , contentsProp
+  , delaySec
   , encodeMap
   , encodeTagged
   , encodeTagged'
@@ -26,6 +27,8 @@ module Ctl.Internal.Helpers
   , maybeArrayMerge
   , mkErrorRecord
   , notImplemented
+  , race
+  , raceMany
   , showWithParens
   , tagProp
   , uIntToBigInt
@@ -34,13 +37,16 @@ module Ctl.Internal.Helpers
 import Prelude
 
 import Aeson (class EncodeAeson, Aeson, encodeAeson, toString)
-import Control.Monad.Error.Class (class MonadError, throwError)
+import Control.Alt ((<|>))
+import Control.Monad.Error.Class (class MonadError, throwError, try)
+import Control.Parallel (parallel, sequential)
 import Data.Array (union)
 import Data.Bifunctor (bimap)
 import Data.BigInt (BigInt)
 import Data.BigInt as BigInt
 import Data.Bitraversable (ltraverse)
 import Data.Either (Either(Right), either)
+import Data.Foldable (class Foldable, foldl)
 import Data.Function (on)
 import Data.JSDate (now)
 import Data.List.Lazy as LL
@@ -53,13 +59,15 @@ import Data.Maybe (Maybe(Just, Nothing), fromJust, fromMaybe, maybe)
 import Data.Maybe.First (First(First))
 import Data.Maybe.Last (Last(Last))
 import Data.String (Pattern(Pattern), null, stripPrefix, stripSuffix)
+import Data.Time.Duration (Seconds, convertDuration)
 import Data.Traversable (traverse)
 import Data.Tuple (snd, uncurry)
 import Data.Tuple.Nested (type (/\), (/\))
 import Data.Typelevel.Undefined (undefined)
 import Data.UInt (UInt)
 import Data.UInt as UInt
 import Effect (Effect)
+import Effect.Aff (Aff, delay, never)
 import Effect.Class (class MonadEffect)
 import Effect.Class.Console (log)
 import Effect.Exception (throw)
@@ -282,3 +290,23 @@ concatPaths a b =
   right = fromMaybe b (stripPrefix (Pattern "/") b)
 
 infixr 5 concatPaths as <</>> -- </> is taken
+
+-- | Runs two `Aff` actions concurrently
+-- | Get resolved by the first which either resolves or throws
+-- | Expected properties:
+-- | race x y = race y x
+-- | race x (race y z) = race (race x y) z
+-- | race never x = x
+race :: forall (a :: Type). Aff a -> Aff a -> Aff a
+race f g = liftEither =<< sequential (parallel (try f) <|> parallel (try g))
+
+-- | Runs multiple `Aff` actions concurrently
+-- | raceMany [] = never
+-- | raceMany [f] = f
+-- | raceMany [f, g, h] = race (race f g) h
+raceMany
+  :: forall (a :: Type) (f :: Type -> Type). Foldable f => f (Aff a) -> Aff a
+raceMany = foldl race never
+
+delaySec :: Seconds -> Aff Unit
+delaySec seconds = delay $ convertDuration seconds

src/Internal/Test/E2E/Feedback/Node.purs

@@ -3,100 +3,71 @@
 -- | See `Ctl.Internal.Test.E2E.Feedback.Browser` for the corresponding APIs
 -- | for the NodeJS side.
 module Ctl.Internal.Test.E2E.Feedback.Node
-  ( getBrowserEvents
+  ( setClusterSetup
   , subscribeToBrowserEvents
-  , setClusterSetup
   ) where
 
 import Prelude
 
 import Aeson (decodeAeson, encodeAeson, parseJsonStringToAeson, stringifyAeson)
-import Ctl.Internal.Helpers (liftEither)
+import Control.Lazy (fix)
+import Ctl.Internal.Helpers (delaySec, liftEither, race)
 import Ctl.Internal.QueryM (ClusterSetup)
-import Ctl.Internal.Test.E2E.Feedback (BrowserEvent(Failure, Success))
-import Data.Array as Array
-import Data.Either (Either(Left), hush, note)
-import Data.Foldable (and)
-import Data.Maybe (Maybe(Just, Nothing))
+import Ctl.Internal.Test.E2E.Feedback (BrowserEvent)
+import Data.Either (hush, note)
+import Data.Time.Duration (Seconds(Seconds))
 import Data.Traversable (for, traverse_)
-import Effect (Effect)
-import Effect.Aff
-  ( Aff
-  , Canceler(Canceler)
-  , Milliseconds(Milliseconds)
-  , delay
-  , forkAff
-  , killFiber
-  , launchAff_
-  , makeAff
-  , try
-  )
+import Effect.AVar as AVarSync
+import Effect.Aff (Aff, launchAff_)
+import Effect.Aff.AVar as AVar
 import Effect.Class (liftEffect)
 import Effect.Console as Console
-import Effect.Exception (error, throw)
+import Effect.Exception (error, message)
 import Effect.Ref as Ref
 import Effect.Uncurried (mkEffectFn1)
 import Foreign (unsafeFromForeign)
 import Toppokki as Toppokki
 
 -- | React to events raised by the browser
+-- |
+-- | Takes a page and a function which provides you with
+-- | a `wait` `Aff` action, wich, when performed, produce you the next `BrowserEvent`
+-- | or throws an error
 subscribeToBrowserEvents
   :: Toppokki.Page
-  -> (BrowserEvent -> Effect Unit)
+  -> (Aff BrowserEvent -> Aff Unit)
   -> Aff Unit
 subscribeToBrowserEvents page cont = do
   logs <- liftEffect $ Ref.new ""
-  let
-    addLogLine line = Ref.modify_ (flip append (line <> "\n")) logs
-  liftEffect $ Toppokki.onConsole
-    ( mkEffectFn1 \cm -> launchAff_ do
+  eventAVar <- AVar.empty
+
+  let addLogLine line = Ref.modify_ (flip append (line <> "\n")) logs
+
+  liftEffect do
+    flip Toppokki.onConsole page $
+      mkEffectFn1 \cm -> launchAff_ do
         Toppokki.consoleMessageText cm >>= liftEffect <<< addLogLine
-    )
-    page
-  makeAff \f -> do
-    liftEffect $ Toppokki.onPageError
-      ( mkEffectFn1
-          ( \err -> do
-              allLogs <- Ref.read logs
-              Console.log allLogs
-              f $ Left err
-          )
-      )
-      page
-    let
-      -- Accepts a number of attempts left.
-      -- An attempt is successful if we get at least one event.
-      process :: Maybe Int -> Aff Unit
-      process attempts = do
-        events <- getBrowserEvents page
-        continue <- and <$> for events \event -> do
-          void $ liftEffect $ try $ cont event
-          case event of
-            Success -> pure false
-            Failure err -> liftEffect $ throw err
-            _ -> pure true
-        if continue then do
-          delay $ Milliseconds $ 1000.0
-          if Array.length events == 0 && attempts /= Just 0 then
-            process (flip sub one <$> attempts)
-          else if attempts == Just 0 then liftEffect $ f $ Left $ error
-            "Timeout reached when trying to connect to CTL Contract running\
-            \ in the browser. Is there a Contract with E2E hooks available\
-            \ at the URL you provided? Did you forget to run `npm run \
-            \e2e-serve`?"
-          else process Nothing
-        else pure unit
 
-    processFiber <- Ref.new Nothing
-    launchAff_ do
-      liftEffect <<< flip Ref.write processFiber <<< Just =<< forkAff do
-        try (process (Just firstTimeConnectionAttempts)) >>= liftEffect <<< f
-    pure $ Canceler \e -> do
-      liftEffect (Ref.read processFiber) >>= traverse_ (killFiber e)
-  where
-  -- How many times to try until we get any event?
-  firstTimeConnectionAttempts :: Int
-  firstTimeConnectionAttempts = 10
+    flip Toppokki.onPageError page $
+      mkEffectFn1 \err -> do
+        allLogs <- Ref.read logs
+        Console.log allLogs
+
+        let errStr = "Page error occured: " <> message err <> "\n" <> allLogs
+        AVarSync.kill (error errStr) eventAVar
+
+  let
+    -- Asyncronously gets browser events and pushes
+    -- to the `eventVAar` one by one.
+    watcher = fix \this -> do
+      getBrowserEvents page >>= traverse_ (_ `AVar.put` eventAVar)
+      delaySec (Seconds 0.5) *> this
+
+    handler = cont $ AVar.take eventAVar
+
+  -- Watcher loop, normally, runs forever
+  -- Gets resolved by handler or if watcher throws an error
+  race watcher handler
 
 getBrowserEvents
   :: Toppokki.Page -> Aff (Array BrowserEvent)

src/Internal/Test/E2E/Runner.purs

@@ -13,7 +13,7 @@ import Control.Alt ((<|>))
 import Control.Monad.Error.Class (liftMaybe)
 import Control.Promise (Promise, toAffE)
 import Ctl.Internal.Deserialization.Keys (privateKeyFromBytes)
-import Ctl.Internal.Helpers (liftedM, (<</>>))
+import Ctl.Internal.Helpers (delaySec, liftedM, raceMany, (<</>>))
 import Ctl.Internal.Plutip.Server (withPlutipContractEnv)
 import Ctl.Internal.Plutip.Types (PlutipConfig)
 import Ctl.Internal.Plutip.UtxoDistribution (withStakeKey)
@@ -76,7 +76,7 @@ import Ctl.Internal.Wallet.Key
 import Data.Array (catMaybes, mapMaybe, nub)
 import Data.Array as Array
 import Data.BigInt as BigInt
-import Data.Either (Either(Left, Right), isLeft)
+import Data.Either (Either(Right, Left))
 import Data.Foldable (fold)
 import Data.HTTP.Method (Method(GET))
 import Data.Int as Int
@@ -94,15 +94,7 @@ import Data.Traversable (for, for_)
 import Data.Tuple (Tuple(Tuple))
 import Data.UInt as UInt
 import Effect (Effect)
-import Effect.Aff
-  ( Aff
-  , Canceler(Canceler)
-  , fiberCanceler
-  , launchAff
-  , launchAff_
-  , makeAff
-  , try
-  )
+import Effect.Aff (Aff, Canceler(Canceler), makeAff, never, throwError)
 import Effect.Aff.Class (liftAff)
 import Effect.Class (liftEffect)
 import Effect.Console (log)
@@ -240,11 +232,11 @@ testPlan
 testPlan opts@{ tests } rt@{ wallets } =
   group "E2E tests" do
     for_ tests \testEntry@{ specString } -> test specString $ case testEntry of
-      { url, wallet: NoWallet } -> do
+      { url, wallet: NoWallet } ->
         withBrowser opts.noHeadless opts.extraBrowserArgs rt Nothing \browser ->
-          do
-            withE2ETest opts.skipJQuery (wrap url) browser \{ page } -> do
-              subscribeToTestStatusUpdates page
+          withE2ETest opts.skipJQuery (wrap url) browser \{ page } ->
+            subscribeToTestStatusUpdates page
+
       { url, wallet: PlutipCluster } -> do
         let
           distr = withStakeKey privateStakeKey
@@ -269,10 +261,11 @@ testPlan opts@{ tests } rt@{ wallets } =
                     }
                 }
             withBrowser opts.noHeadless opts.extraBrowserArgs rt Nothing
-              \browser -> do
+              \browser ->
                 withE2ETest opts.skipJQuery (wrap url) browser \{ page } -> do
                   setClusterSetup page clusterSetup
                   subscribeToTestStatusUpdates page
+
       { url, wallet: WalletExtension wallet } -> do
         { password, extensionId } <- liftEffect
           $ liftMaybe
@@ -303,26 +296,73 @@ testPlan opts@{ tests } rt@{ wallets } =
                   , confirmAccess: confirmAccess extensionId re
                   , sign: sign extensionId password re
                   }
-              makeAff $ \k -> do
+
+              subscribeToBrowserEvents page \waitNextEvent -> do
                 let
-                  rethrow aff = launchAff_ do
-                    res <- try aff
-                    when (isLeft res) $ liftEffect $ k res
-                map fiberCanceler $ launchAff $ (try >=> k >>> liftEffect) $
-                  subscribeToBrowserEvents page
-                    case _ of
-                      ConfirmAccess -> rethrow someWallet.confirmAccess
-                      Sign -> rethrow someWallet.sign
+                  handler event = do
+                    case event of
+                      ConfirmAccess -> do
+                        handler =<< raceMany
+                          [ someWallet.confirmAccess *> never
+                          , waitNextEvent
+                          , delaySec (Seconds 100.0) *>
+                              throwError (error nextAfterConfirmAccess)
+                          ]
+                      Sign -> do
+                        handler =<< raceMany
+                          [ someWallet.sign *> never
+                          , waitNextEvent
+                          , delaySec (Seconds 100.0) *>
+                              throwError (error nextAfterSign)
+                          ]
                       Success -> pure unit
-                      Failure _ -> pure unit -- error raised directly inside `subscribeToBrowserEvents`
+                      Failure err -> throwError $ error $ failureEventReceived
+                        err
+
+                handler =<< raceMany
+                  [ waitNextEvent
+                  , delaySec (Seconds 10.0) *>
+                      throwError (error noEventsReceived)
+                  ]
   where
+  noEventsReceived =
+    "Timeout reached when trying to connect to CTL Contract running\
+    \ in the browser. No events received.\
+    \ Is there a Contract with E2E hooks available\
+    \ at the URL you provided? Did you forget to run `npm run \
+    \e2e-serve`?"
+
+  nextAfterConfirmAccess =
+    "Timeout reached when trying to get the next event after ConfirmAccess"
+
+  nextAfterSign =
+    "Timeout reached when trying to get the next event after Sign"
+
+  failureEventReceived errStr = "Failure event received: " <> errStr
+
   subscribeToTestStatusUpdates :: Toppokki.Page -> Aff Unit
   subscribeToTestStatusUpdates page =
-    subscribeToBrowserEvents page
-      case _ of
-        Success -> pure unit
-        Failure err -> throw err
-        _ -> pure unit
+    subscribeToBrowserEvents page \waitNextEvent -> do
+      let
+
+        handler event =
+          case event of
+            ConfirmAccess -> handler =<< raceMany
+              [ waitNextEvent
+              , delaySec (Seconds 10.0) *> throwError
+                  (error nextAfterConfirmAccess)
+              ]
+            Sign -> handler =<< raceMany
+              [ waitNextEvent
+              , delaySec (Seconds 10.0) *> throwError (error nextAfterSign)
+              ]
+            Success -> pure unit
+            Failure err -> throwError $ error $ failureEventReceived err
+
+      handler =<< raceMany
+        [ waitNextEvent
+        , delaySec (Seconds 10.0) *> throwError (error noEventsReceived)
+        ]
 
 -- | Implements `browser` command.
 runBrowser