fix: generalize timeout
This commit is contained in:
parent
f0c0e2a32b
commit
459a3ce3c9
GPG Key ID:
6D4165AE4C928719
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user