diff --git a/src/Puppeteer.Base.purs b/src/Puppeteer.Base.purs index ef15caa..3ef78b5 100644 --- a/src/Puppeteer.Base.purs +++ b/src/Puppeteer.Base.purs @@ -2,16 +2,17 @@ module Puppeteer.Base where import Prelude -import Control.Alt ((<|>)) -import Control.Monad.Error.Class (liftMaybe, try) +import Control.Alt (class Alt, (<|>)) +import Control.Monad.Error.Class (class MonadError, liftMaybe, try) import Control.Monad.Except (runExcept) -import Control.Parallel (parallel, sequential) +import Control.Parallel (class Parallel, parallel, sequential) import Data.Bifunctor (lmap) import Data.Either (Either(..), hush) import Data.Map (Map) import Data.Maybe (Maybe(..)) import Data.Time.Duration (Milliseconds) import Effect.Aff (Aff, delay) +import Effect.Aff.Class (class MonadAff, liftAff) import Effect.Exception (Error, error) import Foreign (Foreign, unsafeFromForeign) import Foreign.Object (Object) @@ -44,15 +45,20 @@ mapToObject = Object.fromFoldableWithIndex <<< map writeImpl merge :: forall a b c. Union a b c => Record a -> Record b -> Record c merge a b = unsafeUnion a b -timeout :: forall a. Milliseconds -> Aff a -> Aff (Maybe a) +timeout :: forall ms mp a e. Parallel mp ms => Alt mp => MonadError e ms => MonadAff ms => Milliseconds -> ms a -> ms (Maybe a) timeout t a = let - timeout_ = const Nothing <$> delay t + delay' :: ms Unit + delay' = liftAff $ delay t + timeout_ = const Nothing <$> delay' in sequential $ parallel (hush <$> try a) <|> parallel timeout_ -timeoutThrow :: forall a. Milliseconds -> Aff a -> Aff a -timeoutThrow t a = liftMaybe (error "timeout") =<< timeout t a +timeout' :: forall ms mp a. Parallel mp ms => Alt mp => MonadError Error ms => MonadAff ms => Milliseconds -> ms a -> ms a +timeout' = timeoutThrow (error "timeout") + +timeoutThrow :: forall ms mp a e. Parallel mp ms => Alt mp => MonadError e ms => MonadAff ms => e -> Milliseconds -> ms a -> ms a +timeoutThrow err t a = liftMaybe err =<< timeout t a newtype Context (a :: Symbol) = Context (Unit -> Aff Unit) diff --git a/test/Puppeteer.Handle.Spec.purs b/test/Puppeteer.Handle.Spec.purs index f8568b9..1d14081 100644 --- a/test/Puppeteer.Handle.Spec.purs +++ b/test/Puppeteer.Handle.Spec.purs @@ -19,8 +19,8 @@ import Effect.Class (liftEffect) import Effect.Exception (error) import Node.Buffer as Buffer import Node.URL as Node.URL +import Puppeteer (timeout') import Puppeteer as Pup -import Puppeteer.Base (timeoutThrow) import Puppeteer.Browser as Pup.Browser import Puppeteer.Eval as Pup.Eval import Puppeteer.Handle as Pup.Handle @@ -151,7 +151,7 @@ spec = withPage $ describe "Handle" do log <- forkAff $ Pup.Page.Event.once Pup.Page.Event.Console p button <- liftMaybe (error "button#clickme not found!") =<< Pup.Page.findFirst (S.button `S.hasId` "clickme") p f button - log' <- timeoutThrow (wrap 100.0) $ joinFiber log + log' <- timeout' (wrap 100.0) $ joinFiber log ConsoleMessage.text log' `shouldEqual` "clicked!" test "click" $ clickOrTap Pup.Handle.click @@ -202,7 +202,7 @@ spec = withPage $ describe "Handle" do pure $ if Array.length as' == 4 then Done as' else Loop as' logs <- forkAff $ tailRecM collectLogs [] Pup.Handle.drop dragme dropme - logs' <- timeoutThrow (wrap 1000.0) $ joinFiber logs + logs' <- timeout' (wrap 1000.0) $ joinFiber logs (ConsoleMessage.text <$> logs') `shouldEqual` [ "drag", "dragenter", "dragover", "dragend" ] test "screenshot" \p -> do @@ -214,7 +214,7 @@ spec = withPage $ describe "Handle" do sel <- liftMaybe (error "select not found!") =<< Pup.Page.findFirst S.select p log <- forkAff $ Pup.Page.Event.once Pup.Page.Event.Console p Pup.Handle.select [ "foo" ] sel - log' <- timeoutThrow (wrap 1000.0) $ joinFiber log + log' <- timeout' (wrap 1000.0) $ joinFiber log ConsoleMessage.text log' `shouldEqual` "select(foo)" test "getProperties" \p -> do diff --git a/test/Puppeteer.Page.Event.Spec.purs b/test/Puppeteer.Page.Event.Spec.purs index 78e5325..621cadd 100644 --- a/test/Puppeteer.Page.Event.Spec.purs +++ b/test/Puppeteer.Page.Event.Spec.purs @@ -15,7 +15,7 @@ import Effect.Aff (Aff, launchAff_, delay, forkAff, joinFiber) import Effect.Exception as Error import Puppeteer (timeout) import Puppeteer as Pup -import Puppeteer.Base (timeoutThrow) +import Puppeteer.Base (timeout') import Puppeteer.Browser as Pup.Browser import Puppeteer.HTTP.Request as Pup.HTTP.Request import Puppeteer.Page as Pup.Page @@ -71,7 +71,7 @@ spec = let handle = void <<< liftST <<< flip ST.Ref.modify errorsST <<< Array.cons listening <- liftEffect $ Pup.Page.Event.listen Pup.Page.Event.PageError handle p void $ Pup.Page.addScriptTag (Pup.Page.AddScriptInline scriptError) p - err <- timeoutThrow (wrap 1000.0) $ untilJust (liftST $ Array.head <$> ST.Ref.read errorsST) + err <- timeout' (wrap 1000.0) $ untilJust (liftST $ Array.head <$> ST.Ref.read errorsST) Error.message err `shouldEqual` "eek!" Pup.closeContext listening @@ -91,7 +91,7 @@ spec = withPage $ test "Dialog" \p -> failOnPageError p do dialogF <- forkAff $ Pup.Page.Event.once Pup.Page.Event.Dialog p script <- forkAff $ Pup.Page.addScriptTag (Pup.Page.AddScriptInline scriptDialog) p - dialog <- timeoutThrow (wrap 3000.0) $ joinFiber dialogF + dialog <- timeout' (wrap 3000.0) $ joinFiber dialogF Dialog.dismiss dialog void $ joinFiber script @@ -105,9 +105,9 @@ spec = requestIntercepted <- forkAff $ Pup.Page.HTTP.interceptNextRequest onrequest p log <- forkAff $ Pup.Page.Event.once Pup.Page.Event.Console p loadEvent <- forkAff $ Pup.Page.setContent pageRequestsJs Pup.Load p - timeoutThrow (wrap 1000.0) $ joinFiber requestIntercepted - timeoutThrow (wrap 1000.0) $ joinFiber loadEvent - log' <- timeoutThrow (wrap 1000.0) $ joinFiber log + timeout' (wrap 1000.0) $ joinFiber requestIntercepted + timeout' (wrap 1000.0) $ joinFiber loadEvent + log' <- timeout' (wrap 1000.0) $ joinFiber log ConsoleMessage.text log' `shouldEqual` "hi" withPage $ test "DomContentLoaded, Load" \p -> failOnPageError p do @@ -132,8 +132,8 @@ spec = let shouldBeLoaded yn = shouldEqual yn =<< map isJust loaded' shouldBeLoaded false _ <- liftST $ ST.Ref.write true continueST - timeoutThrow (wrap 100.0) $ joinFiber requestIntercepted - timeoutThrow (wrap 100.0) $ joinFiber f + timeout' (wrap 100.0) $ joinFiber requestIntercepted + timeout' (wrap 100.0) $ joinFiber f shouldBeLoaded true test "Close" \b -> do diff --git a/test/Puppeteer.Page.Spec.purs b/test/Puppeteer.Page.Spec.purs index caaa381..a9612f4 100644 --- a/test/Puppeteer.Page.Spec.purs +++ b/test/Puppeteer.Page.Spec.purs @@ -12,7 +12,7 @@ import Effect.Aff (Aff) import Effect.Class (liftEffect) import Effect.Exception (error) import Puppeteer as Pup -import Puppeteer.Base (timeoutThrow) +import Puppeteer.Base (timeout') import Puppeteer.Handle as Pup.Handle import Puppeteer.Handle.HTML as Pup.Handle.HTML import Puppeteer.Keyboard as Pup.Keyboard @@ -166,7 +166,7 @@ spec = beforeAll (Pup.launch_ =<< Pup.new) failOnPageError p do Pup.Page.setContent simplePage Pup.Load p _ <- Pup.Page.addScriptTag (Pup.Page.AddScriptInline scriptAddBar) p - _ <- timeoutThrow (Milliseconds 5000.0) $ Pup.Page.WaitFor.selector "div#bar" p + _ <- timeout' (Milliseconds 5000.0) $ Pup.Page.WaitFor.selector "div#bar" p Pup.Page.close p test "keyboard" \b -> do