@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
12{-# LANGUAGE BangPatterns #-}
23{-# LANGUAGE StandaloneDeriving #-}
34{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -24,18 +25,16 @@ import Control.Monad.Catch
2425import Control.Monad.Fix
2526import Control.Monad.IO.Class
2627import Control.Monad.Ref
27−import Data.Constraint (Dict(..))
2828import Data.Constraint.Extras
2929import Data.Constraint.Extras.TH
3030import Data.Dependent.Map (DMap)
3131import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
32−import Data.Foldable (traverse_)
3332import Data.Functor.Identity
3433import Data.Functor.Misc
3534import Data.GADT.Compare.TH
3635import Data.GADT.Show.TH
3736import Data.IORef (IORef)
38−import Data.Maybe (fromMaybe, fromJust)
37+import Data.Maybe
3938import Data.Proxy
4039import Data.Text (Text)
4140import Language.Javascript.JSaddle (syncPoint, liftJSM)
@@ -47,14 +46,15 @@ import Network.WebSockets
4746import Reflex.Dom.Core
4847import Reflex.Patch.DMapWithMove
4948import System.Directory
49+import System.Environment
5050import System.IO (stderr)
5151import System.IO.Silently
5252import System.IO.Temp
5353import System.Process
54−import System.Timeout.Lifted
5554import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
5655import qualified Test.Hspec as H
57−import Test.Hspec.WebDriver hiding (runWD)
56+import Test.Hspec (xit)
57+import Test.Hspec.WebDriver hiding (runWD, click, uploadFile)
5858import qualified Test.Hspec.WebDriver as WD
5959import Test.WebDriver (WD)
6060
@@ -69,6 +69,13 @@ import qualified System.FilePath as FilePath
6969import qualified Test.WebDriver as WD
7070import qualified Test.WebDriver.Capabilities as WD
7171
72+import Test.Util.ChromeFlags
73+import Test.Util.UnshareNetwork
74+
75+seleniumPort, jsaddlePort :: PortNumber
76+seleniumPort = 8000
77+jsaddlePort = 8001
78+
7279-- TODO Remove orphan
7380deriving instance MonadRef WD
7481
@@ -78,11 +85,8 @@ assertEqual a b = liftIO . HUnit.assertEqual a b
7885assertFailure :: MonadIO m => String -> m ()
7986assertFailure = liftIO . HUnit.assertFailure
8087
81−testTimeLimit :: Int
82−testTimeLimit = 5 * 1000 * 1000
83−
84−chromeConfig :: Text -> WD.WDConfig
85−chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
88+chromeConfig :: Text -> [Text] -> WD.WDConfig
89+chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
8690
8791keyMap :: DMap DKey Identity
8892keyMap = DMap.fromList
@@ -119,17 +123,34 @@ instance EqTag DKey Identity where
119123 eqTagged Key_Bool Key_Bool = (==)
120124
121125main :: IO ()
122−main = withSeleniumServer $ \selenium -> do
123− browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
124− when (T.null browserPath) $ fail "No browser found"
125− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
126− chromeCaps' = WD.getCaps $ chromeConfig browserPath
127− hspec (tests wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
126+main = do
127+ unshareNetork
128+ isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
129+ withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
130+ withSeleniumServer $ \selenium -> do
131+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
132+ when (T.null browserPath) $ fail "No browser found"
133+ withDebugging <- isJust <$> lookupEnv "DEBUG"
134+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
135+ chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
136+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
128137
129−tests :: WD.WDConfig -> [Capabilities] -> Selenium -> Spec
130−tests wdConfig caps _selenium = do
131− let session' = sessionWith wdConfig "" . using (map (,"") caps)
132− runWD = runWDOptions (WdOptions False)
138+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
139+tests withDebugging wdConfig caps _selenium = do
140+ let putStrLnDebug :: MonadIO m => Text -> m ()
141+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
142+ session' = sessionWith wdConfig "" . using (map (,"") caps)
143+ runWD m = runWDOptions (WdOptions False) $ do
144+ putStrLnDebug "before"
145+ r <- m
146+ putStrLnDebug "after"
147+ return r
148+ testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
149+ testWidgetStatic = testWidgetStaticDebug withDebugging
150+ testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
151+ testWidget = testWidgetDebug withDebugging
152+ testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
153+ testWidget' = testWidgetDebug' withDebugging
133154 describe "text" $ session' $ do
134155 it "works" $ runWD $ do
135156 testWidgetStatic (checkBodyText "hello world") $ do
@@ -185,8 +206,7 @@ tests wdConfig caps _selenium = do
185206 it "updates in immediate mode" $ runWD $ do
186207 let checkUpdated = do
187208 checkBodyText "initial"
188− WD.click =<< WD.findElem (WD.ByTag "button")
189− liftIO $ threadDelay 100000 -- wait for update
209+ WD.click =<< findElemWithRetry (WD.ByTag "button")
190210 checkBodyText "after"
191211 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
192212 click <- button ""
@@ -195,17 +215,16 @@ tests wdConfig caps _selenium = do
195215 describe "element" $ session' $ do
196216 it "works with domEvent Click" $ runWD $ do
197217 clickedRef <- liftIO $ newRef False
198− testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
218+ testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
199219 (e, _) <- el' "div" $ text "hello world"
200220 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
201− clicked <- liftIO $ readRef clickedRef
202− liftIO $ assertEqual "Not clicked" True clicked
221+ readRef clickedRef `shouldBeWithRetryM` True
203222 it "works with eventFlags stopPropagation" $ runWD $ do
204223 firstClickedRef <- newRef False
205224 secondClickedRef <- newRef False
206225 let clickBoth = do
207− WD.findElem (WD.ById "first") >>= WD.click
208− WD.findElem (WD.ById "second") >>= WD.click
226+ findElemWithRetry (WD.ById "first") >>= WD.click
227+ findElemWithRetry (WD.ById "second") >>= WD.click
209228 testWidget (pure ()) clickBoth $ do
210229 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
211230 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -222,7 +241,7 @@ tests wdConfig caps _selenium = do
222241 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
223242 it "works with eventFlags preventDefault" $ runWD $ do
224243 let click = do
225− e <- WD.findElem $ WD.ByTag "input"
244+ e <- findElemWithRetry $ WD.ByTag "input"
226245 s0 <- WD.isSelected e
227246 WD.click e
228247 s1 <- WD.isSelected e
@@ -236,7 +255,7 @@ tests wdConfig caps _selenium = do
236255 assertEqual "Click not prevented" (False, False) clicked
237256 it "can add/update/remove attributes" $ runWD $ do
238257 let checkInitialAttrs = do
239− e <- WD.findElem $ WD.ByTag "div"
258+ e <- findElemWithRetry $ WD.ByTag "div"
240259 assertAttr e "const" (Just "const")
241260 assertAttr e "delete" (Just "delete")
242261 assertAttr e "init" (Just "init")
@@ -244,11 +263,11 @@ tests wdConfig caps _selenium = do
244263 pure e
245264 checkModifyAttrs e = do
246265 WD.click e
247− liftIO $ threadDelay 100000
248− assertAttr e "const" (Just "const")
249− assertAttr e "delete" Nothing
250− assertAttr e "init" (Just "click")
251− assertAttr e "click" (Just "click")
266+ withRetry $ do
267+ assertAttr e "const" (Just "const")
268+ assertAttr e "delete" Nothing
269+ assertAttr e "init" (Just "click")
270+ assertAttr e "click" (Just "click")
252271 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
253272 let conf = def
254273 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -259,7 +278,7 @@ tests wdConfig caps _selenium = do
259278 -- TODO check this is the correct solution
260279 it "has ssr attribute, removes ssr attribute" $ runWD $ do
261280 let checkSSRAttr = do
262− e <- WD.findElem $ WD.ByTag "div"
281+ e <- findElemWithRetry $ WD.ByTag "div"
263282 assertAttr e "data-ssr" (Just "")
264283 pure e
265284 testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
@@ -270,15 +289,13 @@ tests wdConfig caps _selenium = do
270289 inputRef <- newRef ("" :: Text)
271290 testWidget'
272291 (do
273− e <- WD.findElem $ WD.ByTag "input"
292+ e <- findElemWithRetry $ WD.ByTag "input"
274293 WD.sendKeys "hello world" e
275294 pure e)
276295 (\e -> do
277− t <- WD.attr e "value"
278− t `shouldBe` Just "hello world"
279− WD.click <=< WD.findElem $ WD.ByTag "button"
280− input <- liftIO $ readRef inputRef
281− input `shouldBe` "hello world"
296+ WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
297+ WD.click =<< findElemWithRetry (WD.ByTag "button")
298+ readRef inputRef `shouldBeWithRetryM` "hello world"
282299 ) $ do
283300 e <- inputElement def
284301 click <- button "save"
@@ -286,10 +303,9 @@ tests wdConfig caps _selenium = do
286303 it "captures user input after switchover" $ runWD $ do
287304 inputRef <- newRef ("" :: Text)
288305 let checkValue = do
289− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
290− WD.click <=< WD.findElem $ WD.ByTag "button"
291− input <- liftIO $ readRef inputRef
292− input `shouldBe` "hello world"
306+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
307+ WD.click =<< findElemWithRetry (WD.ByTag "button")
308+ readRef inputRef `shouldBeWithRetryM` "hello world"
293309 testWidget (pure ()) checkValue $ do
294310 e <- inputElement def
295311 click <- button "save"
@@ -297,23 +313,21 @@ tests wdConfig caps _selenium = do
297313 it "sets focus appropriately" $ runWD $ do
298314 focusRef <- newRef False
299315 let checkValue = do
300− readRef focusRef >>= flip shouldBe False
301− e <- WD.findElem $ WD.ByTag "input"
316+ readRef focusRef `shouldBeWithRetryM` False
317+ e <- findElemWithRetry $ WD.ByTag "input"
302318 WD.click e
303− liftIO $ threadDelay 100000
304− readRef focusRef >>= flip shouldBe True
319+ readRef focusRef `shouldBeWithRetryM` True
305320 testWidget (pure ()) checkValue $ do
306321 e <- inputElement def
307322 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
308323 it "sets focus when focus occurs before hydration" $ runWD $ do
309324 focusRef <- newRef False
310325 let setup = do
311− e <- WD.findElem $ WD.ByTag "input"
326+ e <- findElemWithRetry $ WD.ByTag "input"
312327 WD.click e
313− hasFocus <- (== e) <$> WD.activeElem
314− hasFocus `shouldBe` True
315− readRef focusRef >>= flip shouldBe False
316− check = readRef focusRef >>= flip shouldBe True
328+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
329+ readRef focusRef `shouldBeWithRetryM` False
330+ check = readRef focusRef `shouldBeWithRetryM` True
317331 testWidget setup check $ do
318332 e <- inputElement def
319333 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -322,17 +336,15 @@ tests wdConfig caps _selenium = do
322336 valueRef <- newRef ("" :: Text)
323337 setValueChan :: Chan Text <- liftIO newChan
324338 let checkValue = do
325− readRef valueByUIRef >>= flip shouldBe ""
326− readRef valueRef >>= flip shouldBe ""
327− e <- WD.findElem $ WD.ByTag "input"
339+ readRef valueByUIRef `shouldBeWithRetryM` ""
340+ readRef valueRef `shouldBeWithRetryM` ""
341+ e <- findElemWithRetry $ WD.ByTag "input"
328342 WD.sendKeys "hello" e
329− liftIO $ threadDelay 100000
330− readRef valueByUIRef >>= flip shouldBe "hello"
331− readRef valueRef >>= flip shouldBe "hello"
343+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
344+ readRef valueRef `shouldBeWithRetryM` "hello"
332345 liftIO $ writeChan setValueChan "world"
333− liftIO $ threadDelay 100000
334− readRef valueByUIRef >>= flip shouldBe "hello"
335− readRef valueRef >>= flip shouldBe "world"
346+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
347+ readRef valueRef `shouldBeWithRetryM` "world"
336348 testWidget (pure ()) checkValue $ do
337349 update <- triggerEventWithChan setValueChan
338350 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -343,18 +355,16 @@ tests wdConfig caps _selenium = do
343355 checkedRef <- newRef False
344356 setCheckedChan <- liftIO newChan
345357 let checkValue = do
346− readRef checkedByUIRef >>= flip shouldBe False
347− readRef checkedRef >>= flip shouldBe False
348− e <- WD.findElem $ WD.ByTag "input"
358+ readRef checkedByUIRef `shouldBeWithRetryM` False
359+ readRef checkedRef `shouldBeWithRetryM` False
360+ e <- findElemWithRetry $ WD.ByTag "input"
349361 WD.moveToCenter e
350362 WD.click e
351− liftIO $ threadDelay 100000
352− readRef checkedByUIRef >>= flip shouldBe True
353− readRef checkedRef >>= flip shouldBe True
363+ readRef checkedByUIRef `shouldBeWithRetryM` True
364+ readRef checkedRef `shouldBeWithRetryM` True
354365 liftIO $ writeChan setCheckedChan False
355− liftIO $ threadDelay 100000
356− readRef checkedByUIRef >>= flip shouldBe True
357− readRef checkedRef >>= flip shouldBe False
366+ readRef checkedByUIRef `shouldBeWithRetryM` True
367+ readRef checkedRef `shouldBeWithRetryM` False
358368 testWidget (pure ()) checkValue $ do
359369 setChecked <- triggerEventWithChan setCheckedChan
360370 e <- inputElement $ def
@@ -365,13 +375,12 @@ tests wdConfig caps _selenium = do
365375 it "captures file uploads" $ runWD $ do
366376 filesRef :: IORef [Text] <- newRef []
367377 let uploadFile = do
368− e <- WD.findElem $ WD.ByTag "input"
378+ e <- findElemWithRetry $ WD.ByTag "input"
369379 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
370380 WD.sendKeys (T.pack path) e
371− WD.click <=< WD.findElem $ WD.ByTag "button"
381+ WD.click =<< findElemWithRetry (WD.ByTag "button")
372382 liftIO $ removeFile path
373− input <- readRef filesRef
374− input `shouldBe` [T.pack $ FilePath.takeFileName path]
383+ readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
375384 testWidget (pure ()) uploadFile $ do
376385 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
377386 click <- button "save"
@@ -383,10 +392,9 @@ tests wdConfig caps _selenium = do
383392 it "captures user input after switchover" $ runWD $ do
384393 inputRef :: IORef Text <- newRef ""
385394 let checkValue = do
386− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
387− WD.click <=< WD.findElem $ WD.ByTag "button"
388− input <- readRef inputRef
389− input `shouldBe` "hello world"
395+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "input")
396+ WD.click =<< findElemWithRetry (WD.ByTag "button")
397+ readRef inputRef `shouldBeWithRetryM` "hello world"
390398 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
391399 e <- inputElement def
392400 click <- button "save"
@@ -394,11 +402,10 @@ tests wdConfig caps _selenium = do
394402 it "sets focus appropriately" $ runWD $ do
395403 focusRef <- newRef False
396404 let checkValue = do
397− readRef focusRef >>= flip shouldBe False
398− e <- WD.findElem $ WD.ByTag "input"
405+ readRef focusRef `shouldBeWithRetryM` False
406+ e <- findElemWithRetry $ WD.ByTag "input"
399407 WD.click e
400− liftIO $ threadDelay 100000
401− readRef focusRef >>= flip shouldBe True
408+ readRef focusRef `shouldBeWithRetryM` True
402409 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
403410 e <- inputElement def
404411 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,17 +414,15 @@ tests wdConfig caps _selenium = do
407414 valueRef :: IORef Text <- newRef ""
408415 setValueChan :: Chan Text <- liftIO newChan
409416 let checkValue = do
410− readRef valueByUIRef >>= flip shouldBe ""
411− readRef valueRef >>= flip shouldBe ""
412− e <- WD.findElem $ WD.ByTag "input"
417+ readRef valueByUIRef `shouldBeWithRetryM` ""
418+ readRef valueRef `shouldBeWithRetryM` ""
419+ e <- findElemWithRetry $ WD.ByTag "input"
413420 WD.sendKeys "hello" e
414− liftIO $ threadDelay 100000
415− readRef valueByUIRef >>= flip shouldBe "hello"
416− readRef valueRef >>= flip shouldBe "hello"
421+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
422+ readRef valueRef `shouldBeWithRetryM` "hello"
417423 liftIO $ writeChan setValueChan "world"
418− liftIO $ threadDelay 100000
419− readRef valueByUIRef >>= flip shouldBe "hello"
420− readRef valueRef >>= flip shouldBe "world"
424+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
425+ readRef valueRef `shouldBeWithRetryM` "world"
421426 testWidget (pure ()) checkValue $ do
422427 update <- triggerEventWithChan setValueChan
423428 prerender_ (pure ()) $ do
@@ -429,18 +434,16 @@ tests wdConfig caps _selenium = do
429434 checkedRef <- newRef False
430435 setCheckedChan <- liftIO newChan
431436 let checkValue = do
432− readRef checkedByUIRef >>= flip shouldBe False
433− readRef checkedRef >>= flip shouldBe False
434− e <- WD.findElem $ WD.ByTag "input"
437+ readRef checkedByUIRef `shouldBeWithRetryM` False
438+ readRef checkedRef `shouldBeWithRetryM` False
439+ e <- findElemWithRetry $ WD.ByTag "input"
435440 WD.moveToCenter e
436441 WD.click e
437− liftIO $ threadDelay 100000
438− readRef checkedByUIRef >>= flip shouldBe True
439− readRef checkedRef >>= flip shouldBe True
442+ readRef checkedByUIRef `shouldBeWithRetryM` True
443+ readRef checkedRef `shouldBeWithRetryM` True
440444 liftIO $ writeChan setCheckedChan False
441− liftIO $ threadDelay 100000
442− readRef checkedByUIRef >>= flip shouldBe True
443− readRef checkedRef >>= flip shouldBe False
445+ readRef checkedByUIRef `shouldBeWithRetryM` True
446+ readRef checkedRef `shouldBeWithRetryM` False
444447 testWidget (pure ()) checkValue $ do
445448 setChecked <- triggerEventWithChan setCheckedChan
446449 prerender_ (pure ()) $ do
@@ -452,13 +455,12 @@ tests wdConfig caps _selenium = do
452455 it "captures file uploads" $ runWD $ do
453456 filesRef :: IORef [Text] <- newRef []
454457 let uploadFile = do
455− e <- WD.findElem $ WD.ByTag "input"
458+ e <- findElemWithRetry $ WD.ByTag "input"
456459 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
457460 WD.sendKeys (T.pack path) e
458− WD.click <=< WD.findElem $ WD.ByTag "button"
461+ WD.click =<< findElemWithRetry (WD.ByTag "button")
459462 liftIO $ removeFile path
460− input <- liftIO $ readRef filesRef
461− input `shouldBe` [T.pack $ FilePath.takeFileName path]
463+ readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
462464 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
463465 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
464466 click <- button "save"
@@ -472,15 +474,13 @@ tests wdConfig caps _selenium = do
472474 inputRef <- newRef ("" :: Text)
473475 testWidget'
474476 (do
475− e <- WD.findElem $ WD.ByTag "textarea"
477+ e <- findElemWithRetry $ WD.ByTag "textarea"
476478 WD.sendKeys "hello world" e
477479 pure e)
478480 (\e -> do
479− t <- WD.attr e "value"
480− t `shouldBe` Just "hello world"
481− WD.click <=< WD.findElem $ WD.ByTag "button"
482− input <- readRef inputRef
483− input `shouldBe` "hello world"
481+ WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
482+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
483+ readRef inputRef `shouldBeWithRetryM` "hello world"
484484 ) $ do
485485 e <- textAreaElement def
486486 click <- button "save"
@@ -488,10 +488,9 @@ tests wdConfig caps _selenium = do
488488 it "captures user input after switchover" $ runWD $ do
489489 inputRef <- newRef ("" :: Text)
490490 let checkValue = do
491− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
492− WD.click <=< WD.findElem $ WD.ByTag "button"
493− input <- readRef inputRef
494− input `shouldBe` "hello world"
491+ WD.sendKeys "hello world" =<< findElemWithRetry (WD.ByTag "textarea")
492+ WD.click =<< findElemWithRetry (WD.ByTag "button")
493+ readRef inputRef `shouldBeWithRetryM` "hello world"
495494 testWidget (pure ()) checkValue $ do
496495 e <- textAreaElement def
497496 click <- button "save"
@@ -499,23 +498,21 @@ tests wdConfig caps _selenium = do
499498 it "sets focus appropriately" $ runWD $ do
500499 focusRef <- newRef False
501500 let checkValue = do
502− readRef focusRef >>= flip shouldBe False
503− e <- WD.findElem $ WD.ByTag "textarea"
501+ readRef focusRef `shouldBeWithRetryM` False
502+ e <- findElemWithRetry $ WD.ByTag "textarea"
504503 WD.click e
505− liftIO $ threadDelay 100000
506− readRef focusRef >>= flip shouldBe True
504+ readRef focusRef `shouldBeWithRetryM` True
507505 testWidget (pure ()) checkValue $ do
508506 e <- textAreaElement def
509507 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
510508 it "sets focus when focus occurs before hydration" $ runWD $ do
511509 focusRef <- newRef False
512510 let setup = do
513− e <- WD.findElem $ WD.ByTag "textarea"
511+ e <- findElemWithRetry $ WD.ByTag "textarea"
514512 WD.click e
515− hasFocus <- (== e) <$> WD.activeElem
516− hasFocus `shouldBe` True
517− readRef focusRef >>= flip shouldBe False
518− check = readRef focusRef >>= flip shouldBe True
513+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
514+ readRef focusRef `shouldBeWithRetryM` False
515+ check = readRef focusRef `shouldBeWithRetryM` True
519516 testWidget setup check $ do
520517 e <- textAreaElement def
521518 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -524,17 +521,15 @@ tests wdConfig caps _selenium = do
524521 valueRef <- newRef ("" :: Text)
525522 setValueChan :: Chan Text <- liftIO newChan
526523 let checkValue = do
527− readRef valueByUIRef >>= flip shouldBe ""
528− readRef valueRef >>= flip shouldBe ""
529− e <- WD.findElem $ WD.ByTag "textarea"
524+ readRef valueByUIRef `shouldBeWithRetryM` ""
525+ readRef valueRef `shouldBeWithRetryM` ""
526+ e <- findElemWithRetry $ WD.ByTag "textarea"
530527 WD.sendKeys "hello" e
531− liftIO $ threadDelay 100000
532− readRef valueByUIRef >>= flip shouldBe "hello"
533− readRef valueRef >>= flip shouldBe "hello"
528+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
529+ readRef valueRef `shouldBeWithRetryM` "hello"
534530 liftIO $ writeChan setValueChan "world"
535− liftIO $ threadDelay 100000
536− readRef valueByUIRef >>= flip shouldBe "hello"
537− readRef valueRef >>= flip shouldBe "world"
531+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
532+ readRef valueRef `shouldBeWithRetryM` "world"
538533 testWidget (pure ()) checkValue $ do
539534 setValue' <- triggerEventWithChan setValueChan
540535 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
@@ -545,10 +540,9 @@ tests wdConfig caps _selenium = do
545540 it "captures user input after switchover" $ runWD $ do
546541 inputRef :: IORef Text <- newRef ""
547542 let checkValue = do
548− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
549− WD.click <=< WD.findElem $ WD.ByTag "button"
550− input <- liftIO $ readRef inputRef
551− input `shouldBe` "hello world"
543+ WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"
544+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
545+ readRef inputRef `shouldBeWithRetryM` "hello world"
552546 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
553547 e <- textAreaElement def
554548 click <- button "save"
@@ -556,11 +550,10 @@ tests wdConfig caps _selenium = do
556550 it "sets focus appropriately" $ runWD $ do
557551 focusRef <- newRef False
558552 let checkValue = do
559− readRef focusRef >>= flip shouldBe False
560− e <- WD.findElem $ WD.ByTag "textarea"
553+ readRef focusRef `shouldBeWithRetryM` False
554+ e <- findElemWithRetry $ WD.ByTag "textarea"
561555 WD.click e
562− liftIO $ threadDelay 100000
563− readRef focusRef >>= flip shouldBe True
556+ readRef focusRef `shouldBeWithRetryM` True
564557 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
565558 e <- textAreaElement def
566559 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -569,17 +562,15 @@ tests wdConfig caps _selenium = do
569562 valueRef :: IORef Text <- newRef ""
570563 setValueChan :: Chan Text <- liftIO newChan
571564 let checkValue = do
572− readRef valueByUIRef >>= flip shouldBe ""
573− readRef valueRef >>= flip shouldBe ""
574− e <- WD.findElem $ WD.ByTag "textarea"
565+ readRef valueByUIRef `shouldBeWithRetryM` ""
566+ readRef valueRef `shouldBeWithRetryM` ""
567+ e <- findElemWithRetry $ WD.ByTag "textarea"
575568 WD.sendKeys "hello" e
576− liftIO $ threadDelay 100000
577− readRef valueByUIRef >>= flip shouldBe "hello"
578− readRef valueRef >>= flip shouldBe "hello"
569+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
570+ readRef valueRef `shouldBeWithRetryM` "hello"
579571 liftIO $ writeChan setValueChan "world"
580− liftIO $ threadDelay 100000
581− readRef valueByUIRef >>= flip shouldBe "hello"
582− readRef valueRef >>= flip shouldBe "world"
572+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
573+ readRef valueRef `shouldBeWithRetryM` "world"
583574 testWidget (pure ()) checkValue $ do
584575 setValue' <- triggerEventWithChan setValueChan
585576 prerender_ (pure ()) $ do
@@ -597,16 +588,16 @@ tests wdConfig caps _selenium = do
597588 it "sets initial value correctly" $ runWD $ do
598589 inputRef <- newRef ("" :: Text)
599590 let setup = do
600− e <- WD.findElem $ WD.ByTag "select"
591+ e <- findElemWithRetry $ WD.ByTag "select"
601592 assertAttr e "value" (Just "three")
602− WD.click <=< WD.findElem $ WD.ById "two"
593+ WD.click =<< findElemWithRetry (WD.ById "two")
603594 pure e
604595 check e = do
605596 assertAttr e "value" (Just "two")
606− readRef inputRef >>= (`shouldBe` "three")
607− WD.click <=< WD.findElem $ WD.ByTag "button"
597+ readRef inputRef `shouldBeWithRetryM` "three"
598+ WD.click =<< findElemWithRetry (WD.ByTag "button")
608599 assertAttr e "value" (Just "two")
609− readRef inputRef >>= (`shouldBe` "two")
600+ readRef inputRef `shouldBeWithRetryM` "two"
610601 testWidget' setup check $ do
611602 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
612603 click <- button "save"
@@ -615,12 +606,12 @@ tests wdConfig caps _selenium = do
615606 it "captures user input after switchover" $ runWD $ do
616607 inputRef <- newRef ("" :: Text)
617608 let checkValue = do
618− e <- WD.findElem $ WD.ByTag "select"
609+ e <- findElemWithRetry $ WD.ByTag "select"
619610 assertAttr e "value" (Just "one")
620− WD.click <=< WD.findElem $ WD.ById "two"
611+ WD.click =<< findElemWithRetry (WD.ById "two")
621612 assertAttr e "value" (Just "two")
622− WD.click <=< WD.findElem $ WD.ByTag "button"
623− readRef inputRef >>= (`shouldBe` "two")
613+ WD.click =<< findElemWithRetry (WD.ByTag "button")
614+ readRef inputRef `shouldBeWithRetryM` "two"
624615 testWidget (pure ()) checkValue $ do
625616 (e, ()) <- selectElement def options
626617 click <- button "save"
@@ -628,23 +619,21 @@ tests wdConfig caps _selenium = do
628619 it "sets focus appropriately" $ runWD $ do
629620 focusRef <- newRef False
630621 let checkValue = do
631− readRef focusRef >>= flip shouldBe False
632− e <- WD.findElem $ WD.ByTag "select"
622+ readRef focusRef `shouldBeWithRetryM` False
623+ e <- findElemWithRetry $ WD.ByTag "select"
633624 WD.click e
634− liftIO $ threadDelay 100000
635− readRef focusRef >>= flip shouldBe True
625+ readRef focusRef `shouldBeWithRetryM` True
636626 testWidget (pure ()) checkValue $ do
637627 (e, ()) <- selectElement def options
638628 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
639629 it "sets focus when focus occurs before hydration" $ runWD $ do
640630 focusRef <- newRef False
641631 let setup = do
642− e <- WD.findElem $ WD.ByTag "select"
632+ e <- findElemWithRetry $ WD.ByTag "select"
643633 WD.click e
644− hasFocus <- (== e) <$> WD.activeElem
645− hasFocus `shouldBe` True
646− readRef focusRef >>= flip shouldBe False
647− check = readRef focusRef >>= flip shouldBe True
634+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
635+ readRef focusRef `shouldBeWithRetryM` False
636+ check = readRef focusRef `shouldBeWithRetryM` True
648637 testWidget setup check $ do
649638 (e, ()) <- selectElement def options
650639 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -653,18 +642,16 @@ tests wdConfig caps _selenium = do
653642 valueRef <- newRef ("" :: Text)
654643 setValueChan :: Chan Text <- liftIO newChan
655644 let checkValue = do
656− e <- WD.findElem $ WD.ByTag "select"
645+ e <- findElemWithRetry $ WD.ByTag "select"
657646 assertAttr e "value" (Just "one")
658− readRef valueByUIRef >>= flip shouldBe "one"
659− readRef valueRef >>= flip shouldBe "one"
660− WD.click <=< WD.findElem $ WD.ById "two"
661− liftIO $ threadDelay 100000
662− readRef valueByUIRef >>= flip shouldBe "two"
663− readRef valueRef >>= flip shouldBe "two"
647+ readRef valueByUIRef `shouldBeWithRetryM` "one"
648+ readRef valueRef `shouldBeWithRetryM` "one"
649+ WD.click <=< findElemWithRetry $ WD.ById "two"
650+ readRef valueByUIRef `shouldBeWithRetryM` "two"
651+ readRef valueRef `shouldBeWithRetryM` "two"
664652 liftIO $ writeChan setValueChan "three"
665− liftIO $ threadDelay 100000
666− readRef valueByUIRef >>= flip shouldBe "two"
667− readRef valueRef >>= flip shouldBe "three"
653+ readRef valueByUIRef `shouldBeWithRetryM` "two"
654+ readRef valueRef `shouldBeWithRetryM` "three"
668655 testWidget (pure ()) checkValue $ do
669656 setValue' <- triggerEventWithChan setValueChan
670657 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
@@ -675,9 +662,9 @@ tests wdConfig caps _selenium = do
675662 it "captures user input after switchover" $ runWD $ do
676663 inputRef :: IORef Text <- newRef ""
677664 let checkValue = do
678− WD.click <=< WD.findElem $ WD.ById "two"
679− WD.click <=< WD.findElem $ WD.ByTag "button"
680− readRef inputRef >>= flip shouldBe "two"
665+ WD.click <=< findElemWithRetry $ WD.ById "two"
666+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
667+ readRef inputRef `shouldBeWithRetryM` "two"
681668 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
682669 (e, ()) <- selectElement def options
683670 click <- button "save"
@@ -685,17 +672,16 @@ tests wdConfig caps _selenium = do
685672 it "sets focus appropriately" $ runWD $ do
686673 focusRef <- newRef False
687674 let checkValue = do
688− readRef focusRef >>= flip shouldBe False
689− e <- WD.findElem $ WD.ByTag "select"
675+ readRef focusRef `shouldBeWithRetryM` False
676+ e <- findElemWithRetry $ WD.ByTag "select"
690677 WD.click e
691− liftIO $ threadDelay 100000
692− readRef focusRef >>= flip shouldBe True
678+ readRef focusRef `shouldBeWithRetryM` True
693679 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
694680 (e, ()) <- selectElement def options
695681 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
696682 it "has correct initial value" $ runWD $ do
697683 valueRef :: IORef Text <- newRef ""
698− let checkValue = readRef valueRef >>= flip shouldBe "one"
684+ let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
699685 testWidget (pure ()) checkValue $ do
700686 prerender_ (pure ()) $ do
701687 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -705,14 +691,12 @@ tests wdConfig caps _selenium = do
705691 valueRef :: IORef Text <- newRef ""
706692 setValueChan :: Chan Text <- liftIO newChan
707693 let checkValue = do
708− WD.click <=< WD.findElem $ WD.ById "two"
709− liftIO $ threadDelay 100000
710− readRef valueByUIRef >>= flip shouldBe "two"
711− readRef valueRef >>= flip shouldBe "two"
694+ WD.click =<< findElemWithRetry (WD.ById "two")
695+ readRef valueByUIRef `shouldBeWithRetryM` "two"
696+ readRef valueRef `shouldBeWithRetryM` "two"
712697 liftIO $ writeChan setValueChan "three"
713− liftIO $ threadDelay 100000
714− readRef valueByUIRef >>= flip shouldBe "two"
715− readRef valueRef >>= flip shouldBe "three"
698+ readRef valueByUIRef `shouldBeWithRetryM` "two"
699+ readRef valueRef `shouldBeWithRetryM` "three"
716700 testWidget (pure ()) checkValue $ do
717701 setValue' <- triggerEventWithChan setValueChan
718702 prerender_ (pure ()) $ do
@@ -725,7 +709,7 @@ tests wdConfig caps _selenium = do
725709 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
726710 prerender_ (text "One") (text "Two")
727711 it "removes element correctly" $ runWD $ do
728− testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
712+ testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
729713 prerender_ (el "span" $ text "One") (text "Two")
730714 it "can be nested in server widget" $ runWD $ do
731715 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -765,8 +749,8 @@ tests wdConfig caps _selenium = do
765749 pb <- getPostBuild
766750 performEvent_ $ liftIO (putMVar lock ()) <$ pb
767751 it "result Dynamic is updated *after* switchover" $ runWD $ do
768− let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
769− check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
752+ let static = checkBodyText "PostBuild"
753+ check = checkBodyText "Client"
770754 testWidget static check $ void $ do
771755 d <- prerender (pure "Initial") (pure "Client")
772756 pb <- getPostBuild
@@ -775,15 +759,15 @@ tests wdConfig caps _selenium = do
775759 -- This essentially checks that the client IO runs *after* switchover/postBuild,
776760 -- thus can't create conflicting DOM
777761 it "can't exploit IO to break hydration" $ runWD $ do
778− let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
762+ let static = checkBodyText "Initial"
779763 testWidgetStatic static $ void $ do
780764 ref <- liftIO $ newRef "Initial"
781765 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
782766 text <=< liftIO $ readRef ref
783767 -- As above, so below
784768 it "can't exploit triggerEvent to break hydration" $ runWD $ do
785− let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
786− check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
769+ let static = checkBodyText "Initial"
770+ check = checkBodyText "Client"
787771 testWidget static check $ void $ do
788772 (e, trigger) <- newTriggerEvent
789773 prerender_ (pure ()) (liftIO $ trigger "Client")
@@ -792,15 +776,13 @@ tests wdConfig caps _selenium = do
792776 describe "runWithReplace" $ session' $ do
793777 it "works" $ runWD $ do
794778 replaceChan :: Chan Text <- liftIO newChan
795− let setup = WD.findElem $ WD.ByTag "div"
779+ let setup = findElemWithRetry $ WD.ByTag "div"
796780 check ssr = do
797781 -- Check that the original element still exists and has the correct text
798− WD.getText ssr >>= flip shouldBe "two"
799− liftIO $ do
800− writeChan replaceChan "three"
801− threadDelay 100000
782+ shouldContainText "two" ssr
783+ liftIO $ writeChan replaceChan "three"
802784 elementShouldBeRemoved ssr
803− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
785+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
804786 testWidget' setup check $ do
805787 replace <- triggerEventWithChan replaceChan
806788 pb <- getPostBuild
@@ -810,15 +792,13 @@ tests wdConfig caps _selenium = do
810792 ]
811793 it "can be nested in initial widget" $ runWD $ do
812794 replaceChan :: Chan Text <- liftIO newChan
813− let setup = WD.findElem $ WD.ByTag "div"
795+ let setup = findElemWithRetry $ WD.ByTag "div"
814796 check ssr = do
815797 -- Check that the original element still exists and has the correct text
816− WD.getText ssr >>= flip shouldBe "two"
817− liftIO $ do
818− writeChan replaceChan "three"
819− threadDelay 100000
798+ shouldContainText "two" ssr
799+ liftIO $ writeChan replaceChan "three"
820800 elementShouldBeRemoved ssr
821− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
801+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
822802 testWidget' setup check $ void $ flip runWithReplace never $ do
823803 replace <- triggerEventWithChan replaceChan
824804 pb <- getPostBuild
@@ -828,15 +808,13 @@ tests wdConfig caps _selenium = do
828808 ]
829809 it "can be nested in postBuild widget" $ runWD $ do
830810 replaceChan <- liftIO newChan
831− let setup = WD.findElem $ WD.ByTag "div"
811+ let setup = findElemWithRetry $ WD.ByTag "div"
832812 check ssr = do
833813 -- Check that the original element still exists and has the correct text
834− WD.getText ssr >>= flip shouldBe "two"
835− liftIO $ do
836− writeChan replaceChan "three"
837− threadDelay 100000
814+ shouldContainText "two" ssr
815+ liftIO $ writeChan replaceChan "three"
838816 elementShouldBeRemoved ssr
839− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
817+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
840818 testWidget' setup check $ void $ do
841819 pb <- getPostBuild
842820 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -862,17 +840,15 @@ tests wdConfig caps _selenium = do
862840 replaceChan2 :: Chan Text <- liftIO newChan
863841 lock :: MVar () <- liftIO newEmptyMVar
864842 let check = do
865− shouldContainText "" =<< WD.findElem (WD.ByTag "body")
843+ shouldContainText "" =<< findElemWithRetry (WD.ByTag "body")
866844 liftIO $ do
867845 writeChan replaceChan1 "one"
868846 takeMVar lock
869− one <- WD.findElem $ WD.ByTag "div"
870− WD.getText one >>= flip shouldBe "pb"
871− liftIO $ do
872− writeChan replaceChan2 "two"
873− threadDelay 100000
847+ one <- findElemWithRetry $ WD.ByTag "div"
848+ shouldContainText "pb" one
849+ liftIO $ writeChan replaceChan2 "two"
874850 elementShouldBeRemoved one
875− shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
851+ shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
876852 testWidget (pure ()) check $ void $ do
877853 replace1 <- triggerEventWithChan replaceChan1
878854 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -913,14 +889,12 @@ tests wdConfig caps _selenium = do
913889 it "works in immediate mode (RHS of prerender)" $ runWD $ do
914890 replaceChan :: Chan Text <- liftIO newChan
915891 let check = do
916− one <- WD.findElem $ WD.ByTag "div"
917− shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
918− WD.getText one >>= flip shouldBe "one"
919− liftIO $ do
920− writeChan replaceChan "pb"
921− threadDelay 100000
892+ checkBodyText "one"
893+ one <- findElemWithRetry $ WD.ByTag "div"
894+ shouldContainText "one" one
895+ liftIO $ writeChan replaceChan "pb"
922896 elementShouldBeRemoved one
923− shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
897+ shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
924898 testWidget (pure ()) check $ void $ do
925899 replace <- triggerEventWithChan replaceChan
926900 prerender_ blank $ do
@@ -928,14 +902,12 @@ tests wdConfig caps _selenium = do
928902 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
929903 replaceChan :: Chan Text <- liftIO newChan
930904 let check = do
931− two <- WD.findElem $ WD.ByTag "div"
932− shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
933− WD.getText two >>= flip shouldBe "two"
934− liftIO $ do
935− writeChan replaceChan "three"
936− threadDelay 100000
905+ checkBodyText "two"
906+ two <- findElemWithRetry $ WD.ByTag "div"
907+ shouldContainText "two" two
908+ liftIO $ writeChan replaceChan "three"
937909 elementShouldBeRemoved two
938− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
910+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
939911 testWidget (pure ()) check $ void $ do
940912 replace <- triggerEventWithChan replaceChan
941913 prerender_ blank $ do
@@ -953,34 +925,34 @@ tests wdConfig caps _selenium = do
953925 pure (Identity v)
954926 checkItem :: WD.Element -> Text -> Text -> WD ()
955927 checkItem li k v = do
956− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
957− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
928+ putStrLnDebug "checkItem"
929+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
930+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
958931 checkInitialItems dm xs = do
932+ putStrLnDebug "checkInitialItems"
959933 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
960934 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
961− getAndCheckInitialItems dm = do
935+ getAndCheckInitialItems dm = withRetry $ do
936+ putStrLnDebug "getAndCheckInitialItems"
962937 xs <- WD.findElems (WD.ByTag "li")
963938 checkInitialItems dm xs
964939 pure xs
965940 checkRemoval chan k = do
966− e <- WD.findElem (WD.ById $ textKey k)
967− liftIO $ do
968− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
969− threadDelay 100000
941+ putStrLnDebug "checkRemoval"
942+ e <- findElemWithRetry (WD.ById $ textKey k)
943+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
970944 elementShouldBeRemoved e
971945 checkReplace chan k v = do
972− e <- WD.findElem (WD.ById $ textKey k)
973− liftIO $ do
974− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
975− threadDelay 100000
946+ putStrLnDebug "checkReplace"
947+ e <- findElemWithRetry (WD.ById $ textKey k)
948+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
976949 elementShouldBeRemoved e
977− e' <- WD.findElem (WD.ById $ textKey k)
950+ e' <- findElemWithRetry $ WD.ById $ textKey k
978951 checkItem e' (textKey k) (T.pack $ show v)
979952 checkInsert chan k v = do
980− liftIO $ do
981− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
982− threadDelay 100000
983− e <- WD.findElem (WD.ById $ textKey k)
953+ putStrLnDebug "checkInsert"
954+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
955+ e <- findElemWithRetry (WD.ById $ textKey k)
984956 checkItem e (textKey k) (T.pack $ show v)
985957 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
986958 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
@@ -998,9 +970,9 @@ tests wdConfig caps _selenium = do
998970 liftIO $ dmap `H.shouldBe` keyMap
999971 it "handles postBuild correctly" $ runWD $ do
1000972 chan <- liftIO newChan
1001− let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
973+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1002974 check xs = do
1003− checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
975+ withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1004976 checkRemoval chan Key_Int
1005977 checkInsert chan Key_Char 'B'
1006978 checkReplace chan Key_Bool True
@@ -1037,7 +1009,7 @@ tests wdConfig caps _selenium = do
10371009 it "handles postBuild correctly in prerender" $ runWD $ do
10381010 chan <- liftIO newChan
10391011 let check = do
1040− _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1012+ _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
10411013 checkRemoval chan Key_Int
10421014 checkInsert chan Key_Char 'B'
10431015 checkReplace chan Key_Bool True
@@ -1062,37 +1034,37 @@ tests wdConfig caps _selenium = do
10621034 pure v
10631035 checkItem :: WD.Element -> Text -> Text -> WD ()
10641036 checkItem li k v = do
1065− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1066− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1037+ putStrLnDebug "checkItem"
1038+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1039+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
10671040 checkInitialItems dm xs = do
1041+ putStrLnDebug "checkInitialItems"
10681042 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
10691043 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1070− getAndCheckInitialItems dm = do
1044+ getAndCheckInitialItems dm = withRetry $ do
1045+ putStrLnDebug "getAndCheckInitialItems"
10711046 xs <- WD.findElems (WD.ByTag "li")
10721047 checkInitialItems dm xs
10731048 pure xs
10741049 checkRemoval chan k = do
1075− e <- WD.findElem (WD.ById $ textKeyInt k)
1076− liftIO $ do
1077− writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1078− threadDelay 100000
1050+ putStrLnDebug "checkRemoval"
1051+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
1052+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
10791053 elementShouldBeRemoved e
10801054 checkReplace chan k v = do
1081− e <- WD.findElem (WD.ById $ textKeyInt k)
1082− liftIO $ do
1083− writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1084− threadDelay 100000
1055+ putStrLnDebug "checkReplace"
1056+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
1057+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
10851058 elementShouldBeRemoved e
1086− e' <- WD.findElem (WD.ById $ textKeyInt k)
1087− checkItem e' (textKeyInt k) v
1059+ e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1060+ withRetry $ checkItem e' (textKeyInt k) v
10881061 checkInsert chan k v = do
1089− liftIO $ do
1090− writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1091− threadDelay 100000
1092− e <- WD.findElem (WD.ById $ textKeyInt k)
1062+ putStrLnDebug "checkInsert"
1063+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1064+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
10931065 checkItem e (textKeyInt k) v
10941066 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1095− it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
1067+ xit "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
10961068 chan <- liftIO newChan
10971069 let static = getAndCheckInitialItems intMap
10981070 check xs = do
@@ -1103,11 +1075,11 @@ tests wdConfig caps _selenium = do
11031075 testWidget' static check $ void $ do
11041076 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
11051077 liftIO $ im `H.shouldBe` intMap
1106− it "handles postBuild correctly" $ runWD $ do
1078+ xit "handles postBuild correctly" $ runWD $ do
11071079 chan <- liftIO newChan
1108− let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1080+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
11091081 check xs = do
1110− checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
1082+ withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
11111083 checkRemoval chan 1
11121084 checkInsert chan 2 "deux"
11131085 checkReplace chan 3 "trois"
@@ -1116,35 +1088,35 @@ tests wdConfig caps _selenium = do
11161088 replace <- triggerEventWithChan chan
11171089 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
11181090 liftIO $ dmap `H.shouldBe` intMap
1119− it "can delete/update/insert when built in prerender" $ runWD $ do
1091+ xit "can delete/update/insert when built in prerender" $ runWD $ do
11201092 chan <- liftIO newChan
11211093 let check = do
11221094 _ <- getAndCheckInitialItems intMap
11231095 checkRemoval chan 1
11241096 checkReplace chan 2 "deux"
1125− checkInsert chan 3 "trois"
1097+ checkInsert chan 4 "quatre"
11261098 testWidget (pure ()) check $ do
11271099 replace <- triggerEventWithChan chan
11281100 prerender_ (pure ()) $ do
11291101 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
11301102 liftIO $ dmap `H.shouldBe` intMap
1131− it "can delete/update/insert when built in immediate mode" $ runWD $ do
1103+ xit "can delete/update/insert when built in immediate mode" $ runWD $ do
11321104 chan <- liftIO newChan
11331105 let check = do
11341106 _ <- getAndCheckInitialItems intMap
11351107 checkRemoval chan 1
11361108 checkReplace chan 2 "deux"
1137− checkInsert chan 3 "trois"
1109+ checkInsert chan 4 "quatre"
11381110 testWidget (pure ()) check $ void $ do
11391111 pb <- getPostBuild
11401112 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
11411113 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
11421114 liftIO $ dmap `H.shouldBe` intMap
11431115 -- Should be fixed by prerender changes!
1144− it "handles postBuild correctly in prerender" $ runWD $ do
1116+ xit "handles postBuild correctly in prerender" $ runWD $ do
11451117 chan <- liftIO newChan
11461118 let check = do
1147− _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1119+ _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
11481120 checkRemoval chan 1
11491121 checkInsert chan 2 "deux"
11501122 checkReplace chan 3 "trois"
@@ -1157,45 +1129,25 @@ tests wdConfig caps _selenium = do
11571129
11581130 describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
11591131 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1160− widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1161− elClass "span" "key" $ text $ textKey k
1132+ widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1133+ elClass "span" "key" $ text $ textKey2 k
11621134 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
11631135 pure (Identity v)
1164− textKey :: Key2 a -> Text
1165− textKey = \case
1136+ textKey2 :: Key2 a -> Text
1137+ textKey2 = \case
11661138 Key2_Int i -> "i" <> T.pack (show i)
11671139 Key2_Char c -> "c" <> T.pack [c]
11681140 checkItem :: WD.Element -> Text -> Text -> WD ()
11691141 checkItem li k v = do
1170− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1171− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1142+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1143+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
11721144 checkInitialItems dm xs = do
11731145 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1174− forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
1175− getAndCheckInitialItems dm = do
1146+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
1147+ getAndCheckInitialItems dm = withRetry $ do
11761148 xs <- WD.findElems (WD.ByTag "li")
11771149 checkInitialItems dm xs
11781150 pure xs
1179− checkRemoval chan k = do
1180− e <- WD.findElem (WD.ById $ textKey k)
1181− liftIO $ do
1182− writeChan chan $ deleteDMapKey k
1183− threadDelay 100000
1184− elementShouldBeRemoved e
1185− checkReplace chan k v = do
1186− e <- WD.findElem (WD.ById $ textKey k)
1187− liftIO $ do
1188− writeChan chan $ insertDMapKey k (Identity v)
1189− threadDelay 100000
1190− elementShouldBeRemoved e
1191− e' <- WD.findElem (WD.ById $ textKey k)
1192− checkItem e' (textKey k) (T.pack $ show v)
1193− checkInsert chan k v = do
1194− liftIO $ do
1195− writeChan chan $ insertDMapKey k (Identity v)
1196− threadDelay 100000
1197− e <- WD.findElem (WD.ById $ textKey k)
1198− checkItem e (textKey k) (T.pack $ show v)
11991151 moveSpec testMove = do
12001152 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
12011153 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1226,7 +1178,7 @@ tests wdConfig caps _selenium = do
12261178 let static = getAndCheckInitialItems initMap
12271179 check xs = do
12281180 checkInitialItems initMap xs
1229− body <- WD.findElem (WD.ByTag "body")
1181+ body <- getBody
12301182 test body chan
12311183 testWidget' static check $ void $ do
12321184 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
@@ -1242,7 +1194,7 @@ tests wdConfig caps _selenium = do
12421194 takeMVar lock
12431195 xs <- getAndCheckInitialItems initMap
12441196 checkInitialItems initMap xs
1245− body <- WD.findElem (WD.ByTag "body")
1197+ body <- getBody
12461198 test body chan
12471199 testWidget (pure ()) check $ void $ do
12481200 e <- triggerEventWithChan replace
@@ -1255,17 +1207,16 @@ tests wdConfig caps _selenium = do
12551207 describe "hydrating invalid HTML" $ session' $ do
12561208 it "can hydrate list in paragraph" $ runWD $ do
12571209 let static = do
1258− body <- WD.findElem (WD.ByTag "body")
1259− shouldContainText "before\ninner\nafter" body
1210+ checkBodyText "before\ninner\nafter"
12601211 -- Two <p> tags should be present
12611212 [p1, p2] <- WD.findElems (WD.ByTag "p")
1262− ol <- WD.findElem (WD.ByTag "ol")
1213+ ol <- findElemWithRetry (WD.ByTag "ol")
12631214 shouldContainText "before" p1
12641215 shouldContainText "inner" ol
12651216 shouldContainText "" p2
1266− pure (body, p1, ol, p2)
1267− check (body, p1, ol, p2) = do
1268− shouldContainText "before\ninner\nafter" body
1217+ pure (p1, ol, p2)
1218+ check (p1, ol, p2) = do
1219+ checkBodyText "before\ninner\nafter"
12691220 shouldContainText "before\ninner\nafter" p1
12701221 elementShouldBeRemoved ol
12711222 elementShouldBeRemoved p2
@@ -1293,11 +1244,10 @@ startSeleniumServer port = do
12931244
12941245withSeleniumServer :: (Selenium -> IO ()) -> IO ()
12951246withSeleniumServer f = do
1296− port <- getFreePort
1297− stopServer <- startSeleniumServer port
1247+ stopServer <- startSeleniumServer seleniumPort
12981248 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
12991249 f $ Selenium
1300− { _selenium_portNumber = port
1250+ { _selenium_portNumber = seleniumPort
13011251 , _selenium_stopServer = stopServer
13021252 }
13031253
@@ -1308,122 +1258,152 @@ triggerEventWithChan chan = do
13081258 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
13091259 pure e
13101260
1261+shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1262+shouldBeWithRetryM m expected = withRetry $ do
1263+ got <- m
1264+ got `shouldBe` expected
1265+
13111266assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
13121267assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
13131268
13141269elementShouldBeRemoved :: WD.Element -> WD ()
1315−elementShouldBeRemoved e = do
1270+elementShouldBeRemoved e = withRetry $ do
13161271 try (WD.getText e) >>= \case
13171272 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
13181273 Left err -> throwM err
13191274 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
13201275
13211276shouldContainText :: Text -> WD.Element -> WD ()
1322−shouldContainText t = flip shouldBe t <=< WD.getText
1277+shouldContainText t = withRetry . shouldContainTextNoRetry t
1278+
1279+shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
1280+shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
13231281
13241282checkBodyText :: Text -> WD ()
13251283checkBodyText = checkTextInTag "body"
13261284
13271285checkTextInTag :: Text -> Text -> WD ()
1328−checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
1286+checkTextInTag t expected = do
1287+ e <- findElemWithRetry (WD.ByTag t)
1288+ shouldContainText expected e
13291289
13301290checkTextInId :: Text -> Text -> WD ()
1331−checkTextInId i expected = WD.findElem (WD.ById i) >>= shouldContainText expected
1291+checkTextInId i expected = do
1292+ e <- findElemWithRetry (WD.ById i)
1293+ shouldContainText expected e
1294+
1295+findElemWithRetry :: Selector -> WD WD.Element
1296+findElemWithRetry = withRetry . WD.findElem
1297+
1298+getBody :: WD WD.Element
1299+getBody = WD.findElem $ WD.ByTag "body"
1300+
1301+withRetry :: forall a. WD a -> WD a
1302+withRetry a = wait 300
1303+ where wait :: Int -> WD a
1304+ wait 0 = a
1305+ wait n = try a >>= \case
1306+ Left (_ :: SomeException) -> do
1307+ liftIO $ threadDelay 100000
1308+ wait $ n - 1
1309+ Right v -> return v
13321310
13331311divId :: DomBuilder t m => Text -> m a -> m a
13341312divId i = elAttr "div" ("id" =: i)
13351313
13361314type TestWidget js t m = (DomBuilder t m, MonadHold t m, PostBuild t m, Prerender js t m, PerformEvent t m, TriggerEvent t m, MonadFix m, MonadIO (Performable m), MonadIO m)
13371315
1338−testWidgetStatic
1339− :: WD b
1316+testWidgetStaticDebug
1317+ :: Bool
1318+ -> WD b
13401319 -- ^ Webdriver commands to run before JS runs and after hydration switchover
13411320 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
13421321 -- ^ Widget we are testing
13431322 -> WD b
1344−testWidgetStatic w = testWidget (void w) w
1323+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
13451324
13461325-- | TODO: do something about JSExceptions not causing tests to fail
1347−testWidget
1348− :: WD ()
1326+testWidgetDebug
1327+ :: Bool
1328+ -> WD ()
13491329 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
13501330 -> WD b
13511331 -- ^ Webdriver commands to run after hydration switchover
13521332 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
13531333 -- ^ Widget we are testing
13541334 -> WD b
1355−testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
1335+testWidgetDebug withDebugging beforeJS afterSwitchover =
1336+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
13561337
13571338-- | TODO: do something about JSExceptions not causing tests to fail
1358−testWidget'
1359− :: WD a
1339+testWidgetDebug'
1340+ :: Bool
1341+ -> WD a
13601342 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
13611343 -> (a -> WD b)
13621344 -- ^ Webdriver commands to run after hydration switchover
13631345 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
13641346 -- ^ Widget we are testing (contents of body)
13651347 -> WD b
1366−testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ do
1367− let staticApp = do
1348+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1349+ let putStrLnDebug :: MonadIO m => Text -> m ()
1350+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1351+ staticApp = do
13681352 el "head" $ pure ()
13691353 el "body" $ do
13701354 bodyWidget
13711355 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1356+ putStrLnDebug "rendering static"
13721357 ((), html) <- liftIO $ renderStatic staticApp
1358+ putStrLnDebug "rendered static"
13731359 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
13741360 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
13751361 let entryPoint = do
1362+ putStrLnDebug "taking waitBeforeJS"
13761363 liftIO $ takeMVar waitBeforeJS
1377− mainHydrationWidgetWithSwitchoverAction (putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
1364+ let switchOverAction = do
1365+ putStrLnDebug "switchover syncPoint"
1366+ syncPoint
1367+ putStrLnDebug "putting waitUntilSwitchover"
1368+ liftIO $ putMVar waitUntilSwitchover ()
1369+ putStrLnDebug "put waitUntilSwitchover"
1370+ putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1371+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1372+ putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
13781373 syncPoint
1379− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1380− sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1381− port <- getFreePort
1374+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1375+ putStrLnDebug "sending response"
1376+ r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1377+ putStrLnDebug "sent response"
1378+ return r
13821379 waitJSaddle <- liftIO newEmptyMVar
13831380 let settings = foldr ($) Warp.defaultSettings
1384− [ Warp.setPort $ fromIntegral (toInteger port)
1385− , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
1381+ [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
1382+ , Warp.setBeforeMainLoop $ do
1383+ putStrLnDebug "putting waitJSaddle"
1384+ putMVar waitJSaddle ()
1385+ putStrLnDebug "put waitJSaddle"
13861386 ]
13871387 -- hSilence to get rid of ConnectionClosed logs
1388− jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1388+ silenceIfDebug = if withDebugging then id else hSilence [stderr]
1389+ jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
13891390 jsaddleTid <- liftIO jsaddleWarp
1391+ putStrLnDebug "taking waitJSaddle"
13901392 liftIO $ takeMVar waitJSaddle
1391− WD.openPage $ "http://localhost:" <> show port
1393+ putStrLnDebug "opening page"
1394+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1395+ putStrLnDebug "running beforeJS"
13921396 a <- beforeJS
1397+ putStrLnDebug "putting waitBeforeJS"
13931398 liftIO $ putMVar waitBeforeJS ()
1399+ putStrLnDebug "taking waitUntilSwitchover"
13941400 liftIO $ takeMVar waitUntilSwitchover
1395− liftIO $ threadDelay 100000 -- wait a bit
1401+ putStrLnDebug "running afterSwitchover"
13961402 b <- afterSwitchover a
1403+ putStrLnDebug "killing jsaddle thread"
13971404 liftIO $ killThread jsaddleTid
13981405 return b
13991406
1400−
1401−-- TODO: Should this be part of more widely used module?
1402−-- TODO: Ensure port is not taken
1403−getFreePort :: MonadIO m => m PortNumber
1404−getFreePort = liftIO $ withSocketsDo $ do
1405− addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
1406− bracket (open addr) close socketPort
1407− where
1408− open addr = do
1409− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1410− bind sock (addrAddress addr)
1411− return sock
1412−
1413−testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1414−testWidgetDebug bodyWidget = liftIO $ do
1415− let staticApp = do
1416− el "head" $ pure ()
1417− el "body" $ do
1418− bodyWidget
1419− el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1420− ((), html) <- renderStatic staticApp
1421− let entryPoint = do
1422− mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1423− syncPoint
1424− application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1425− Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
1426−
14271407data Key2 a where
14281408 Key2_Int :: Int -> Key2 Int
14291409 Key2_Char :: Char -> Key2 Char