@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE StandaloneDeriving #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -24,18 +25,16 @@ import Control.Monad.Catch
24import Control.Monad.Fix
25import Control.Monad.Fix
25import Control.Monad.IO.Class
26import Control.Monad.IO.Class
26import Control.Monad.Ref
27import Control.Monad.Ref
27−import Data.Constraint (Dict(..))
28import Data.Constraint.Extras
28import Data.Constraint.Extras
29import Data.Constraint.Extras.TH
29import Data.Constraint.Extras.TH
30import Data.Dependent.Map (DMap)
30import Data.Dependent.Map (DMap)
31import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
31import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
32−import Data.Foldable (traverse_)
33import Data.Functor.Identity
32import Data.Functor.Identity
34import Data.Functor.Misc
33import Data.Functor.Misc
35import Data.GADT.Compare.TH
34import Data.GADT.Compare.TH
36import Data.GADT.Show.TH
35import Data.GADT.Show.TH
37import Data.IORef (IORef)
36import Data.IORef (IORef)
38−import Data.Maybe (fromMaybe, fromJust)
37+import Data.Maybe
39import Data.Proxy
38import Data.Proxy
40import Data.Text (Text)
39import Data.Text (Text)
41import Language.Javascript.JSaddle (syncPoint, liftJSM)
40import Language.Javascript.JSaddle (syncPoint, liftJSM)
@@ -47,14 +46,15 @@ import Network.WebSockets
47import Reflex.Dom.Core
46import Reflex.Dom.Core
48import Reflex.Patch.DMapWithMove
47import Reflex.Patch.DMapWithMove
49import System.Directory
48import System.Directory
49+import System.Environment
50import System.IO (stderr)
50import System.IO (stderr)
51import System.IO.Silently
51import System.IO.Silently
52import System.IO.Temp
52import System.IO.Temp
53import System.Process
53import System.Process
54−import System.Timeout.Lifted
55import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
54import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
56import qualified Test.Hspec as H
55import 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)
58import qualified Test.Hspec.WebDriver as WD
58import qualified Test.Hspec.WebDriver as WD
59import Test.WebDriver (WD)
59import Test.WebDriver (WD)
@@ -69,6 +69,13 @@ import qualified System.FilePath as FilePath
69import qualified Test.WebDriver as WD
69import qualified Test.WebDriver as WD
70import qualified Test.WebDriver.Capabilities as WD
70import qualified Test.WebDriver.Capabilities as WD
72+import Test.Util.ChromeFlags
73+import Test.Util.UnshareNetwork
75+seleniumPort, jsaddlePort :: PortNumber
72-- TODO Remove orphan
79-- TODO Remove orphan
73deriving instance MonadRef WD
80deriving instance MonadRef WD
@@ -78,11 +85,8 @@ assertEqual a b = liftIO . HUnit.assertEqual a b
78assertFailure :: MonadIO m => String -> m ()
85assertFailure :: MonadIO m => String -> m ()
79assertFailure = liftIO . HUnit.assertFailure
86assertFailure = liftIO . HUnit.assertFailure
82−testTimeLimit = 5 * 1000 * 1000
84−chromeConfig :: Text -> WD.WDConfig
88+chromeConfig :: Text -> [Text] -> WD.WDConfig
85−chromeConfig fp = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = ["--headless"] }) WD.defaultConfig
89+chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
87keyMap :: DMap DKey Identity
91keyMap :: DMap DKey Identity
88keyMap = DMap.fromList
92keyMap = DMap.fromList
@@ -119,17 +123,34 @@ instance EqTag DKey Identity where
119 eqTagged Key_Bool Key_Bool = (==)
123 eqTagged Key_Bool Key_Bool = (==)
121main :: IO ()
125main :: IO ()
128+ isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
129+ withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
122−main = withSeleniumServer $ \selenium -> do
130+ withSeleniumServer $ \selenium -> do
123− browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
131+ browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
124− when (T.null browserPath) $ fail "No browser found"
132+ when (T.null browserPath) $ fail "No browser found"
133+ withDebugging <- isJust <$> lookupEnv "DEBUG"
125− let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
134+ let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
126− chromeCaps' = WD.getCaps $ chromeConfig browserPath
135+ chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
127− hspec (tests wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
136+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
129−tests :: WD.WDConfig -> [Capabilities] -> Selenium -> Spec
138+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
130−tests wdConfig caps _selenium = do
139+tests withDebugging wdConfig caps _selenium = do
140+ let putStrLnDebug :: MonadIO m => Text -> m ()
141+ putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
131− let session' = sessionWith wdConfig "" . using (map (,"") caps)
142+ session' = sessionWith wdConfig "" . using (map (,"") caps)
132− runWD = runWDOptions (WdOptions False)
143+ runWD m = runWDOptions (WdOptions False) $ do
144+ putStrLnDebug "before"
146+ putStrLnDebug "after"
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
133 describe "text" $ session' $ do
154 describe "text" $ session' $ do
134 it "works" $ runWD $ do
155 it "works" $ runWD $ do
135 testWidgetStatic (checkBodyText "hello world") $ do
156 testWidgetStatic (checkBodyText "hello world") $ do
@@ -185,8 +206,7 @@ tests wdConfig caps _selenium = do
185 it "updates in immediate mode" $ runWD $ do
206 it "updates in immediate mode" $ runWD $ do
186 let checkUpdated = do
207 let checkUpdated = do
187 checkBodyText "initial"
208 checkBodyText "initial"
188− WD.click =<< WD.findElem (WD.ByTag "button")
209+ WD.click =<< findElemWithRetry (WD.ByTag "button")
189− liftIO $ threadDelay 100000 -- wait for update
190 checkBodyText "after"
210 checkBodyText "after"
191 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
211 testWidget (pure ()) checkUpdated $ prerender_ (pure ()) $ do
192 click <- button ""
212 click <- button ""
@@ -195,17 +215,16 @@ tests wdConfig caps _selenium = do
195 describe "element" $ session' $ do
215 describe "element" $ session' $ do
196 it "works with domEvent Click" $ runWD $ do
216 it "works with domEvent Click" $ runWD $ do
197 clickedRef <- liftIO $ newRef False
217 clickedRef <- liftIO $ newRef False
198− testWidget' (WD.findElem $ WD.ByTag "div") WD.click $ do
218+ testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
199 (e, _) <- el' "div" $ text "hello world"
219 (e, _) <- el' "div" $ text "hello world"
200 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
220 performEvent_ $ liftIO (writeRef clickedRef True) <$ domEvent Click e
201− clicked <- liftIO $ readRef clickedRef
221+ readRef clickedRef `shouldBeWithRetryM` True
202− liftIO $ assertEqual "Not clicked" True clicked
203 it "works with eventFlags stopPropagation" $ runWD $ do
222 it "works with eventFlags stopPropagation" $ runWD $ do
204 firstClickedRef <- newRef False
223 firstClickedRef <- newRef False
205 secondClickedRef <- newRef False
224 secondClickedRef <- newRef False
206 let clickBoth = do
225 let clickBoth = do
207− WD.findElem (WD.ById "first") >>= WD.click
226+ findElemWithRetry (WD.ById "first") >>= WD.click
208− WD.findElem (WD.ById "second") >>= WD.click
227+ findElemWithRetry (WD.ById "second") >>= WD.click
209 testWidget (pure ()) clickBoth $ do
228 testWidget (pure ()) clickBoth $ do
210 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
229 (firstDivEl, _) <- el' "div" $ prerender_ (pure ()) $ do
211 void $ elAttr "span" ("id" =: "first") $ text "hello world"
230 void $ elAttr "span" ("id" =: "first") $ text "hello world"
@@ -222,7 +241,7 @@ tests wdConfig caps _selenium = do
222 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
241 assertEqual "Click propagated when it should have stopped" (True, False) (firstClicked, secondClicked)
223 it "works with eventFlags preventDefault" $ runWD $ do
242 it "works with eventFlags preventDefault" $ runWD $ do
224 let click = do
243 let click = do
225− e <- WD.findElem $ WD.ByTag "input"
244+ e <- findElemWithRetry $ WD.ByTag "input"
226 s0 <- WD.isSelected e
245 s0 <- WD.isSelected e
227 WD.click e
246 WD.click e
228 s1 <- WD.isSelected e
247 s1 <- WD.isSelected e
@@ -236,7 +255,7 @@ tests wdConfig caps _selenium = do
236 assertEqual "Click not prevented" (False, False) clicked
255 assertEqual "Click not prevented" (False, False) clicked
237 it "can add/update/remove attributes" $ runWD $ do
256 it "can add/update/remove attributes" $ runWD $ do
238 let checkInitialAttrs = do
257 let checkInitialAttrs = do
239− e <- WD.findElem $ WD.ByTag "div"
258+ e <- findElemWithRetry $ WD.ByTag "div"
240 assertAttr e "const" (Just "const")
259 assertAttr e "const" (Just "const")
241 assertAttr e "delete" (Just "delete")
260 assertAttr e "delete" (Just "delete")
242 assertAttr e "init" (Just "init")
261 assertAttr e "init" (Just "init")
@@ -244,11 +263,11 @@ tests wdConfig caps _selenium = do
245 checkModifyAttrs e = do
264 checkModifyAttrs e = do
246 WD.click e
265 WD.click e
247− liftIO $ threadDelay 100000
266+ withRetry $ do
248− assertAttr e "const" (Just "const")
267+ assertAttr e "const" (Just "const")
249− assertAttr e "delete" Nothing
268+ assertAttr e "delete" Nothing
250− assertAttr e "init" (Just "click")
269+ assertAttr e "init" (Just "click")
251− assertAttr e "click" (Just "click")
270+ assertAttr e "click" (Just "click")
252 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
271 testWidget' checkInitialAttrs checkModifyAttrs $ mdo
253 let conf = def
272 let conf = def
254 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
273 & initialAttributes .~ "const" =: "const" <> "delete" =: "delete" <> "init" =: "init"
@@ -259,7 +278,7 @@ tests wdConfig caps _selenium = do
259 -- TODO check this is the correct solution
278 -- TODO check this is the correct solution
260 it "has ssr attribute, removes ssr attribute" $ runWD $ do
279 it "has ssr attribute, removes ssr attribute" $ runWD $ do
261 let checkSSRAttr = do
280 let checkSSRAttr = do
262− e <- WD.findElem $ WD.ByTag "div"
281+ e <- findElemWithRetry $ WD.ByTag "div"
263 assertAttr e "data-ssr" (Just "")
282 assertAttr e "data-ssr" (Just "")
265 testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
284 testWidget' checkSSRAttr (\e -> assertAttr e "data-ssr" Nothing) $ el "div" $ text "hello world"
@@ -270,15 +289,13 @@ tests wdConfig caps _selenium = do
270 inputRef <- newRef ("" :: Text)
289 inputRef <- newRef ("" :: Text)
271 testWidget'
290 testWidget'
273− e <- WD.findElem $ WD.ByTag "input"
292+ e <- findElemWithRetry $ WD.ByTag "input"
274 WD.sendKeys "hello world" e
293 WD.sendKeys "hello world" e
276 (\e -> do
295 (\e -> do
277− t <- WD.attr e "value"
296+ WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
278− t `shouldBe` Just "hello world"
279− WD.click <=< WD.findElem $ WD.ByTag "button"
297+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
280− input <- liftIO $ readRef inputRef
298+ readRef inputRef `shouldBeWithRetryM` "hello world"
281− input `shouldBe` "hello world"
283 e <- inputElement def
300 e <- inputElement def
284 click <- button "save"
301 click <- button "save"
@@ -286,10 +303,9 @@ tests wdConfig caps _selenium = do
286 it "captures user input after switchover" $ runWD $ do
303 it "captures user input after switchover" $ runWD $ do
287 inputRef <- newRef ("" :: Text)
304 inputRef <- newRef ("" :: Text)
288 let checkValue = do
305 let checkValue = do
289− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
306+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
290− WD.click <=< WD.findElem $ WD.ByTag "button"
307+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
291− input <- liftIO $ readRef inputRef
308+ readRef inputRef `shouldBeWithRetryM` "hello world"
292− input `shouldBe` "hello world"
293 testWidget (pure ()) checkValue $ do
309 testWidget (pure ()) checkValue $ do
294 e <- inputElement def
310 e <- inputElement def
295 click <- button "save"
311 click <- button "save"
@@ -297,23 +313,21 @@ tests wdConfig caps _selenium = do
297 it "sets focus appropriately" $ runWD $ do
313 it "sets focus appropriately" $ runWD $ do
298 focusRef <- newRef False
314 focusRef <- newRef False
299 let checkValue = do
315 let checkValue = do
300− readRef focusRef >>= flip shouldBe False
316+ readRef focusRef `shouldBeWithRetryM` False
301− e <- WD.findElem $ WD.ByTag "input"
317+ e <- findElemWithRetry $ WD.ByTag "input"
302 WD.click e
318 WD.click e
303− liftIO $ threadDelay 100000
304− readRef focusRef >>= flip shouldBe True
319+ readRef focusRef `shouldBeWithRetryM` True
305 testWidget (pure ()) checkValue $ do
320 testWidget (pure ()) checkValue $ do
306 e <- inputElement def
321 e <- inputElement def
307 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
322 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
308 it "sets focus when focus occurs before hydration" $ runWD $ do
323 it "sets focus when focus occurs before hydration" $ runWD $ do
309 focusRef <- newRef False
324 focusRef <- newRef False
310 let setup = do
325 let setup = do
311− e <- WD.findElem $ WD.ByTag "input"
326+ e <- findElemWithRetry $ WD.ByTag "input"
312 WD.click e
327 WD.click e
313− hasFocus <- (== e) <$> WD.activeElem
328+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
314− hasFocus `shouldBe` True
315− readRef focusRef >>= flip shouldBe False
329+ readRef focusRef `shouldBeWithRetryM` False
316− check = readRef focusRef >>= flip shouldBe True
330+ check = readRef focusRef `shouldBeWithRetryM` True
317 testWidget setup check $ do
331 testWidget setup check $ do
318 e <- inputElement def
332 e <- inputElement def
319 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
333 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -322,17 +336,15 @@ tests wdConfig caps _selenium = do
322 valueRef <- newRef ("" :: Text)
336 valueRef <- newRef ("" :: Text)
323 setValueChan :: Chan Text <- liftIO newChan
337 setValueChan :: Chan Text <- liftIO newChan
324 let checkValue = do
338 let checkValue = do
325− readRef valueByUIRef >>= flip shouldBe ""
339+ readRef valueByUIRef `shouldBeWithRetryM` ""
326− readRef valueRef >>= flip shouldBe ""
340+ readRef valueRef `shouldBeWithRetryM` ""
327− e <- WD.findElem $ WD.ByTag "input"
341+ e <- findElemWithRetry $ WD.ByTag "input"
328 WD.sendKeys "hello" e
342 WD.sendKeys "hello" e
329− liftIO $ threadDelay 100000
330− readRef valueByUIRef >>= flip shouldBe "hello"
343+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
331− readRef valueRef >>= flip shouldBe "hello"
344+ readRef valueRef `shouldBeWithRetryM` "hello"
332 liftIO $ writeChan setValueChan "world"
345 liftIO $ writeChan setValueChan "world"
333− liftIO $ threadDelay 100000
334− readRef valueByUIRef >>= flip shouldBe "hello"
346+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
335− readRef valueRef >>= flip shouldBe "world"
347+ readRef valueRef `shouldBeWithRetryM` "world"
336 testWidget (pure ()) checkValue $ do
348 testWidget (pure ()) checkValue $ do
337 update <- triggerEventWithChan setValueChan
349 update <- triggerEventWithChan setValueChan
338 e <- inputElement $ def & inputElementConfig_setValue .~ update
350 e <- inputElement $ def & inputElementConfig_setValue .~ update
@@ -343,18 +355,16 @@ tests wdConfig caps _selenium = do
343 checkedRef <- newRef False
355 checkedRef <- newRef False
344 setCheckedChan <- liftIO newChan
356 setCheckedChan <- liftIO newChan
345 let checkValue = do
357 let checkValue = do
346− readRef checkedByUIRef >>= flip shouldBe False
358+ readRef checkedByUIRef `shouldBeWithRetryM` False
347− readRef checkedRef >>= flip shouldBe False
359+ readRef checkedRef `shouldBeWithRetryM` False
348− e <- WD.findElem $ WD.ByTag "input"
360+ e <- findElemWithRetry $ WD.ByTag "input"
349 WD.moveToCenter e
361 WD.moveToCenter e
350 WD.click e
362 WD.click e
351− liftIO $ threadDelay 100000
352− readRef checkedByUIRef >>= flip shouldBe True
363+ readRef checkedByUIRef `shouldBeWithRetryM` True
353− readRef checkedRef >>= flip shouldBe True
364+ readRef checkedRef `shouldBeWithRetryM` True
354 liftIO $ writeChan setCheckedChan False
365 liftIO $ writeChan setCheckedChan False
355− liftIO $ threadDelay 100000
356− readRef checkedByUIRef >>= flip shouldBe True
366+ readRef checkedByUIRef `shouldBeWithRetryM` True
357− readRef checkedRef >>= flip shouldBe False
367+ readRef checkedRef `shouldBeWithRetryM` False
358 testWidget (pure ()) checkValue $ do
368 testWidget (pure ()) checkValue $ do
359 setChecked <- triggerEventWithChan setCheckedChan
369 setChecked <- triggerEventWithChan setCheckedChan
360 e <- inputElement $ def
370 e <- inputElement $ def
@@ -365,13 +375,12 @@ tests wdConfig caps _selenium = do
365 it "captures file uploads" $ runWD $ do
375 it "captures file uploads" $ runWD $ do
366 filesRef :: IORef [Text] <- newRef []
376 filesRef :: IORef [Text] <- newRef []
367 let uploadFile = do
377 let uploadFile = do
368− e <- WD.findElem $ WD.ByTag "input"
378+ e <- findElemWithRetry $ WD.ByTag "input"
369 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
379 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
370 WD.sendKeys (T.pack path) e
380 WD.sendKeys (T.pack path) e
371− WD.click <=< WD.findElem $ WD.ByTag "button"
381+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
372 liftIO $ removeFile path
382 liftIO $ removeFile path
373− input <- readRef filesRef
374− input `shouldBe` [T.pack $ FilePath.takeFileName path]
383+ readRef filesRef `shouldBeWithRetryM` [T.pack $ FilePath.takeFileName path]
375 testWidget (pure ()) uploadFile $ do
384 testWidget (pure ()) uploadFile $ do
376 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
385 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
377 click <- button "save"
386 click <- button "save"
@@ -383,10 +392,9 @@ tests wdConfig caps _selenium = do
383 it "captures user input after switchover" $ runWD $ do
392 it "captures user input after switchover" $ runWD $ do
384 inputRef :: IORef Text <- newRef ""
393 inputRef :: IORef Text <- newRef ""
385 let checkValue = do
394 let checkValue = do
386− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "input"
395+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "input")
387− WD.click <=< WD.findElem $ WD.ByTag "button"
396+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
388− input <- readRef inputRef
397+ readRef inputRef `shouldBeWithRetryM` "hello world"
389− input `shouldBe` "hello world"
390 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
398 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
391 e <- inputElement def
399 e <- inputElement def
392 click <- button "save"
400 click <- button "save"
@@ -394,11 +402,10 @@ tests wdConfig caps _selenium = do
394 it "sets focus appropriately" $ runWD $ do
402 it "sets focus appropriately" $ runWD $ do
395 focusRef <- newRef False
403 focusRef <- newRef False
396 let checkValue = do
404 let checkValue = do
397− readRef focusRef >>= flip shouldBe False
405+ readRef focusRef `shouldBeWithRetryM` False
398− e <- WD.findElem $ WD.ByTag "input"
406+ e <- findElemWithRetry $ WD.ByTag "input"
399 WD.click e
407 WD.click e
400− liftIO $ threadDelay 100000
401− readRef focusRef >>= flip shouldBe True
408+ readRef focusRef `shouldBeWithRetryM` True
402 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
409 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
403 e <- inputElement def
410 e <- inputElement def
404 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
411 performEvent_ $ liftIO . writeRef focusRef <$> updated (_inputElement_hasFocus e)
@@ -407,17 +414,15 @@ tests wdConfig caps _selenium = do
407 valueRef :: IORef Text <- newRef ""
414 valueRef :: IORef Text <- newRef ""
408 setValueChan :: Chan Text <- liftIO newChan
415 setValueChan :: Chan Text <- liftIO newChan
409 let checkValue = do
416 let checkValue = do
410− readRef valueByUIRef >>= flip shouldBe ""
417+ readRef valueByUIRef `shouldBeWithRetryM` ""
411− readRef valueRef >>= flip shouldBe ""
418+ readRef valueRef `shouldBeWithRetryM` ""
412− e <- WD.findElem $ WD.ByTag "input"
419+ e <- findElemWithRetry $ WD.ByTag "input"
413 WD.sendKeys "hello" e
420 WD.sendKeys "hello" e
414− liftIO $ threadDelay 100000
415− readRef valueByUIRef >>= flip shouldBe "hello"
421+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
416− readRef valueRef >>= flip shouldBe "hello"
422+ readRef valueRef `shouldBeWithRetryM` "hello"
417 liftIO $ writeChan setValueChan "world"
423 liftIO $ writeChan setValueChan "world"
418− liftIO $ threadDelay 100000
419− readRef valueByUIRef >>= flip shouldBe "hello"
424+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
420− readRef valueRef >>= flip shouldBe "world"
425+ readRef valueRef `shouldBeWithRetryM` "world"
421 testWidget (pure ()) checkValue $ do
426 testWidget (pure ()) checkValue $ do
422 update <- triggerEventWithChan setValueChan
427 update <- triggerEventWithChan setValueChan
423 prerender_ (pure ()) $ do
428 prerender_ (pure ()) $ do
@@ -429,18 +434,16 @@ tests wdConfig caps _selenium = do
429 checkedRef <- newRef False
434 checkedRef <- newRef False
430 setCheckedChan <- liftIO newChan
435 setCheckedChan <- liftIO newChan
431 let checkValue = do
436 let checkValue = do
432− readRef checkedByUIRef >>= flip shouldBe False
437+ readRef checkedByUIRef `shouldBeWithRetryM` False
433− readRef checkedRef >>= flip shouldBe False
438+ readRef checkedRef `shouldBeWithRetryM` False
434− e <- WD.findElem $ WD.ByTag "input"
439+ e <- findElemWithRetry $ WD.ByTag "input"
435 WD.moveToCenter e
440 WD.moveToCenter e
436 WD.click e
441 WD.click e
437− liftIO $ threadDelay 100000
438− readRef checkedByUIRef >>= flip shouldBe True
442+ readRef checkedByUIRef `shouldBeWithRetryM` True
439− readRef checkedRef >>= flip shouldBe True
443+ readRef checkedRef `shouldBeWithRetryM` True
440 liftIO $ writeChan setCheckedChan False
444 liftIO $ writeChan setCheckedChan False
441− liftIO $ threadDelay 100000
442− readRef checkedByUIRef >>= flip shouldBe True
445+ readRef checkedByUIRef `shouldBeWithRetryM` True
443− readRef checkedRef >>= flip shouldBe False
446+ readRef checkedRef `shouldBeWithRetryM` False
444 testWidget (pure ()) checkValue $ do
447 testWidget (pure ()) checkValue $ do
445 setChecked <- triggerEventWithChan setCheckedChan
448 setChecked <- triggerEventWithChan setCheckedChan
446 prerender_ (pure ()) $ do
449 prerender_ (pure ()) $ do
@@ -452,13 +455,12 @@ tests wdConfig caps _selenium = do
452 it "captures file uploads" $ runWD $ do
455 it "captures file uploads" $ runWD $ do
453 filesRef :: IORef [Text] <- newRef []
456 filesRef :: IORef [Text] <- newRef []
454 let uploadFile = do
457 let uploadFile = do
455− e <- WD.findElem $ WD.ByTag "input"
458+ e <- findElemWithRetry $ WD.ByTag "input"
456 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
459 path <- liftIO $ writeSystemTempFile "testFile" "file contents"
457 WD.sendKeys (T.pack path) e
460 WD.sendKeys (T.pack path) e
458− WD.click <=< WD.findElem $ WD.ByTag "button"
461+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
459 liftIO $ removeFile path
462 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]
462 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
464 testWidget (pure ()) uploadFile $ prerender_ (pure ()) $ do
463 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
465 e <- inputElement $ def & initialAttributes .~ "type" =: "file"
464 click <- button "save"
466 click <- button "save"
@@ -472,15 +474,13 @@ tests wdConfig caps _selenium = do
472 inputRef <- newRef ("" :: Text)
474 inputRef <- newRef ("" :: Text)
473 testWidget'
475 testWidget'
475− e <- WD.findElem $ WD.ByTag "textarea"
477+ e <- findElemWithRetry $ WD.ByTag "textarea"
476 WD.sendKeys "hello world" e
478 WD.sendKeys "hello world" e
478 (\e -> do
480 (\e -> do
479− t <- WD.attr e "value"
481+ WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
480− t `shouldBe` Just "hello world"
481− WD.click <=< WD.findElem $ WD.ByTag "button"
482+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
482− input <- readRef inputRef
483+ readRef inputRef `shouldBeWithRetryM` "hello world"
483− input `shouldBe` "hello world"
485 e <- textAreaElement def
485 e <- textAreaElement def
486 click <- button "save"
486 click <- button "save"
@@ -488,10 +488,9 @@ tests wdConfig caps _selenium = do
488 it "captures user input after switchover" $ runWD $ do
488 it "captures user input after switchover" $ runWD $ do
489 inputRef <- newRef ("" :: Text)
489 inputRef <- newRef ("" :: Text)
490 let checkValue = do
490 let checkValue = do
491− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
491+ WD.sendKeys "hello world" =<< (findElemWithRetry $ WD.ByTag "textarea")
492− WD.click <=< WD.findElem $ WD.ByTag "button"
492+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
493− input <- readRef inputRef
493+ readRef inputRef `shouldBeWithRetryM` "hello world"
494− input `shouldBe` "hello world"
495 testWidget (pure ()) checkValue $ do
494 testWidget (pure ()) checkValue $ do
496 e <- textAreaElement def
495 e <- textAreaElement def
497 click <- button "save"
496 click <- button "save"
@@ -499,23 +498,21 @@ tests wdConfig caps _selenium = do
499 it "sets focus appropriately" $ runWD $ do
498 it "sets focus appropriately" $ runWD $ do
500 focusRef <- newRef False
499 focusRef <- newRef False
501 let checkValue = do
500 let checkValue = do
502− readRef focusRef >>= flip shouldBe False
501+ readRef focusRef `shouldBeWithRetryM` False
503− e <- WD.findElem $ WD.ByTag "textarea"
502+ e <- findElemWithRetry $ WD.ByTag "textarea"
504 WD.click e
503 WD.click e
505− liftIO $ threadDelay 100000
506− readRef focusRef >>= flip shouldBe True
504+ readRef focusRef `shouldBeWithRetryM` True
507 testWidget (pure ()) checkValue $ do
505 testWidget (pure ()) checkValue $ do
508 e <- textAreaElement def
506 e <- textAreaElement def
509 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
507 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
510 it "sets focus when focus occurs before hydration" $ runWD $ do
508 it "sets focus when focus occurs before hydration" $ runWD $ do
511 focusRef <- newRef False
509 focusRef <- newRef False
512 let setup = do
510 let setup = do
513− e <- WD.findElem $ WD.ByTag "textarea"
511+ e <- findElemWithRetry $ WD.ByTag "textarea"
514 WD.click e
512 WD.click e
515− hasFocus <- (== e) <$> WD.activeElem
513+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
516− hasFocus `shouldBe` True
517− readRef focusRef >>= flip shouldBe False
514+ readRef focusRef `shouldBeWithRetryM` False
518− check = readRef focusRef >>= flip shouldBe True
515+ check = readRef focusRef `shouldBeWithRetryM` True
519 testWidget setup check $ do
516 testWidget setup check $ do
520 e <- textAreaElement def
517 e <- textAreaElement def
521 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
518 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -524,17 +521,15 @@ tests wdConfig caps _selenium = do
524 valueRef <- newRef ("" :: Text)
521 valueRef <- newRef ("" :: Text)
525 setValueChan :: Chan Text <- liftIO newChan
522 setValueChan :: Chan Text <- liftIO newChan
526 let checkValue = do
523 let checkValue = do
527− readRef valueByUIRef >>= flip shouldBe ""
524+ readRef valueByUIRef `shouldBeWithRetryM` ""
528− readRef valueRef >>= flip shouldBe ""
525+ readRef valueRef `shouldBeWithRetryM` ""
529− e <- WD.findElem $ WD.ByTag "textarea"
526+ e <- findElemWithRetry $ WD.ByTag "textarea"
530 WD.sendKeys "hello" e
527 WD.sendKeys "hello" e
531− liftIO $ threadDelay 100000
532− readRef valueByUIRef >>= flip shouldBe "hello"
528+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
533− readRef valueRef >>= flip shouldBe "hello"
529+ readRef valueRef `shouldBeWithRetryM` "hello"
534 liftIO $ writeChan setValueChan "world"
530 liftIO $ writeChan setValueChan "world"
535− liftIO $ threadDelay 100000
536− readRef valueByUIRef >>= flip shouldBe "hello"
531+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
537− readRef valueRef >>= flip shouldBe "world"
532+ readRef valueRef `shouldBeWithRetryM` "world"
538 testWidget (pure ()) checkValue $ do
533 testWidget (pure ()) checkValue $ do
539 setValue' <- triggerEventWithChan setValueChan
534 setValue' <- triggerEventWithChan setValueChan
540 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
535 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
@@ -545,10 +540,9 @@ tests wdConfig caps _selenium = do
545 it "captures user input after switchover" $ runWD $ do
540 it "captures user input after switchover" $ runWD $ do
546 inputRef :: IORef Text <- newRef ""
541 inputRef :: IORef Text <- newRef ""
547 let checkValue = do
542 let checkValue = do
548− WD.sendKeys "hello world" <=< WD.findElem $ WD.ByTag "textarea"
543+ WD.sendKeys "hello world" <=< findElemWithRetry $ WD.ByTag "textarea"
549− WD.click <=< WD.findElem $ WD.ByTag "button"
544+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
550− input <- liftIO $ readRef inputRef
545+ readRef inputRef `shouldBeWithRetryM` "hello world"
551− input `shouldBe` "hello world"
552 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
546 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
553 e <- textAreaElement def
547 e <- textAreaElement def
554 click <- button "save"
548 click <- button "save"
@@ -556,11 +550,10 @@ tests wdConfig caps _selenium = do
556 it "sets focus appropriately" $ runWD $ do
550 it "sets focus appropriately" $ runWD $ do
557 focusRef <- newRef False
551 focusRef <- newRef False
558 let checkValue = do
552 let checkValue = do
559− readRef focusRef >>= flip shouldBe False
553+ readRef focusRef `shouldBeWithRetryM` False
560− e <- WD.findElem $ WD.ByTag "textarea"
554+ e <- findElemWithRetry $ WD.ByTag "textarea"
561 WD.click e
555 WD.click e
562− liftIO $ threadDelay 100000
563− readRef focusRef >>= flip shouldBe True
556+ readRef focusRef `shouldBeWithRetryM` True
564 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
557 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
565 e <- textAreaElement def
558 e <- textAreaElement def
566 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
559 performEvent_ $ liftIO . writeRef focusRef <$> updated (_textAreaElement_hasFocus e)
@@ -569,17 +562,15 @@ tests wdConfig caps _selenium = do
569 valueRef :: IORef Text <- newRef ""
562 valueRef :: IORef Text <- newRef ""
570 setValueChan :: Chan Text <- liftIO newChan
563 setValueChan :: Chan Text <- liftIO newChan
571 let checkValue = do
564 let checkValue = do
572− readRef valueByUIRef >>= flip shouldBe ""
565+ readRef valueByUIRef `shouldBeWithRetryM` ""
573− readRef valueRef >>= flip shouldBe ""
566+ readRef valueRef `shouldBeWithRetryM` ""
574− e <- WD.findElem $ WD.ByTag "textarea"
567+ e <- findElemWithRetry $ WD.ByTag "textarea"
575 WD.sendKeys "hello" e
568 WD.sendKeys "hello" e
576− liftIO $ threadDelay 100000
577− readRef valueByUIRef >>= flip shouldBe "hello"
569+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
578− readRef valueRef >>= flip shouldBe "hello"
570+ readRef valueRef `shouldBeWithRetryM` "hello"
579 liftIO $ writeChan setValueChan "world"
571 liftIO $ writeChan setValueChan "world"
580− liftIO $ threadDelay 100000
581− readRef valueByUIRef >>= flip shouldBe "hello"
572+ readRef valueByUIRef `shouldBeWithRetryM` "hello"
582− readRef valueRef >>= flip shouldBe "world"
573+ readRef valueRef `shouldBeWithRetryM` "world"
583 testWidget (pure ()) checkValue $ do
574 testWidget (pure ()) checkValue $ do
584 setValue' <- triggerEventWithChan setValueChan
575 setValue' <- triggerEventWithChan setValueChan
585 prerender_ (pure ()) $ do
576 prerender_ (pure ()) $ do
@@ -597,16 +588,16 @@ tests wdConfig caps _selenium = do
597 it "sets initial value correctly" $ runWD $ do
588 it "sets initial value correctly" $ runWD $ do
598 inputRef <- newRef ("" :: Text)
589 inputRef <- newRef ("" :: Text)
599 let setup = do
590 let setup = do
600− e <- WD.findElem $ WD.ByTag "select"
591+ e <- findElemWithRetry $ WD.ByTag "select"
601 assertAttr e "value" (Just "three")
592 assertAttr e "value" (Just "three")
602− WD.click <=< WD.findElem $ WD.ById "two"
593+ WD.click =<< (findElemWithRetry $ WD.ById "two")
604 check e = do
595 check e = do
605 assertAttr e "value" (Just "two")
596 assertAttr e "value" (Just "two")
606− readRef inputRef >>= (`shouldBe` "three")
597+ readRef inputRef `shouldBeWithRetryM` "three"
607− WD.click <=< WD.findElem $ WD.ByTag "button"
598+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
608 assertAttr e "value" (Just "two")
599 assertAttr e "value" (Just "two")
609− readRef inputRef >>= (`shouldBe` "two")
600+ readRef inputRef `shouldBeWithRetryM` "two"
610 testWidget' setup check $ do
601 testWidget' setup check $ do
611 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
602 (e, ()) <- selectElement (def { _selectElementConfig_initialValue = "three" }) options
612 click <- button "save"
603 click <- button "save"
@@ -615,12 +606,12 @@ tests wdConfig caps _selenium = do
615 it "captures user input after switchover" $ runWD $ do
606 it "captures user input after switchover" $ runWD $ do
616 inputRef <- newRef ("" :: Text)
607 inputRef <- newRef ("" :: Text)
617 let checkValue = do
608 let checkValue = do
618− e <- WD.findElem $ WD.ByTag "select"
609+ e <- findElemWithRetry $ WD.ByTag "select"
619 assertAttr e "value" (Just "one")
610 assertAttr e "value" (Just "one")
620− WD.click <=< WD.findElem $ WD.ById "two"
611+ WD.click =<< (findElemWithRetry $ WD.ById "two")
621 assertAttr e "value" (Just "two")
612 assertAttr e "value" (Just "two")
622− WD.click <=< WD.findElem $ WD.ByTag "button"
613+ WD.click =<< (findElemWithRetry $ WD.ByTag "button")
623− readRef inputRef >>= (`shouldBe` "two")
614+ readRef inputRef `shouldBeWithRetryM` "two"
624 testWidget (pure ()) checkValue $ do
615 testWidget (pure ()) checkValue $ do
625 (e, ()) <- selectElement def options
616 (e, ()) <- selectElement def options
626 click <- button "save"
617 click <- button "save"
@@ -628,23 +619,21 @@ tests wdConfig caps _selenium = do
628 it "sets focus appropriately" $ runWD $ do
619 it "sets focus appropriately" $ runWD $ do
629 focusRef <- newRef False
620 focusRef <- newRef False
630 let checkValue = do
621 let checkValue = do
631− readRef focusRef >>= flip shouldBe False
622+ readRef focusRef `shouldBeWithRetryM` False
632− e <- WD.findElem $ WD.ByTag "select"
623+ e <- findElemWithRetry $ WD.ByTag "select"
633 WD.click e
624 WD.click e
634− liftIO $ threadDelay 100000
635− readRef focusRef >>= flip shouldBe True
625+ readRef focusRef `shouldBeWithRetryM` True
636 testWidget (pure ()) checkValue $ do
626 testWidget (pure ()) checkValue $ do
637 (e, ()) <- selectElement def options
627 (e, ()) <- selectElement def options
638 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
628 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
639 it "sets focus when focus occurs before hydration" $ runWD $ do
629 it "sets focus when focus occurs before hydration" $ runWD $ do
640 focusRef <- newRef False
630 focusRef <- newRef False
641 let setup = do
631 let setup = do
642− e <- WD.findElem $ WD.ByTag "select"
632+ e <- findElemWithRetry $ WD.ByTag "select"
643 WD.click e
633 WD.click e
644− hasFocus <- (== e) <$> WD.activeElem
634+ ((== e) <$> WD.activeElem) `shouldBeWithRetryM` True
645− hasFocus `shouldBe` True
646− readRef focusRef >>= flip shouldBe False
635+ readRef focusRef `shouldBeWithRetryM` False
647− check = readRef focusRef >>= flip shouldBe True
636+ check = readRef focusRef `shouldBeWithRetryM` True
648 testWidget setup check $ do
637 testWidget setup check $ do
649 (e, ()) <- selectElement def options
638 (e, ()) <- selectElement def options
650 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
639 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
@@ -653,18 +642,16 @@ tests wdConfig caps _selenium = do
653 valueRef <- newRef ("" :: Text)
642 valueRef <- newRef ("" :: Text)
654 setValueChan :: Chan Text <- liftIO newChan
643 setValueChan :: Chan Text <- liftIO newChan
655 let checkValue = do
644 let checkValue = do
656− e <- WD.findElem $ WD.ByTag "select"
645+ e <- findElemWithRetry $ WD.ByTag "select"
657 assertAttr e "value" (Just "one")
646 assertAttr e "value" (Just "one")
658− readRef valueByUIRef >>= flip shouldBe "one"
647+ readRef valueByUIRef `shouldBeWithRetryM` "one"
659− readRef valueRef >>= flip shouldBe "one"
648+ readRef valueRef `shouldBeWithRetryM` "one"
660− WD.click <=< WD.findElem $ WD.ById "two"
649+ WD.click <=< findElemWithRetry $ WD.ById "two"
661− liftIO $ threadDelay 100000
662− readRef valueByUIRef >>= flip shouldBe "two"
650+ readRef valueByUIRef `shouldBeWithRetryM` "two"
663− readRef valueRef >>= flip shouldBe "two"
651+ readRef valueRef `shouldBeWithRetryM` "two"
664 liftIO $ writeChan setValueChan "three"
652 liftIO $ writeChan setValueChan "three"
665− liftIO $ threadDelay 100000
666− readRef valueByUIRef >>= flip shouldBe "two"
653+ readRef valueByUIRef `shouldBeWithRetryM` "two"
667− readRef valueRef >>= flip shouldBe "three"
654+ readRef valueRef `shouldBeWithRetryM` "three"
668 testWidget (pure ()) checkValue $ do
655 testWidget (pure ()) checkValue $ do
669 setValue' <- triggerEventWithChan setValueChan
656 setValue' <- triggerEventWithChan setValueChan
670 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
657 (e, ()) <- selectElement def { _selectElementConfig_setValue = Just setValue' } options
@@ -675,9 +662,9 @@ tests wdConfig caps _selenium = do
675 it "captures user input after switchover" $ runWD $ do
662 it "captures user input after switchover" $ runWD $ do
676 inputRef :: IORef Text <- newRef ""
663 inputRef :: IORef Text <- newRef ""
677 let checkValue = do
664 let checkValue = do
678− WD.click <=< WD.findElem $ WD.ById "two"
665+ WD.click <=< findElemWithRetry $ WD.ById "two"
679− WD.click <=< WD.findElem $ WD.ByTag "button"
666+ WD.click <=< findElemWithRetry $ WD.ByTag "button"
680− readRef inputRef >>= flip shouldBe "two"
667+ readRef inputRef `shouldBeWithRetryM` "two"
681 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
668 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
682 (e, ()) <- selectElement def options
669 (e, ()) <- selectElement def options
683 click <- button "save"
670 click <- button "save"
@@ -685,17 +672,16 @@ tests wdConfig caps _selenium = do
685 it "sets focus appropriately" $ runWD $ do
672 it "sets focus appropriately" $ runWD $ do
686 focusRef <- newRef False
673 focusRef <- newRef False
687 let checkValue = do
674 let checkValue = do
688− readRef focusRef >>= flip shouldBe False
675+ readRef focusRef `shouldBeWithRetryM` False
689− e <- WD.findElem $ WD.ByTag "select"
676+ e <- findElemWithRetry $ WD.ByTag "select"
690 WD.click e
677 WD.click e
691− liftIO $ threadDelay 100000
692− readRef focusRef >>= flip shouldBe True
678+ readRef focusRef `shouldBeWithRetryM` True
693 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
679 testWidget (pure ()) checkValue $ prerender_ (pure ()) $ do
694 (e, ()) <- selectElement def options
680 (e, ()) <- selectElement def options
695 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
681 performEvent_ $ liftIO . writeRef focusRef <$> updated (_selectElement_hasFocus e)
696 it "has correct initial value" $ runWD $ do
682 it "has correct initial value" $ runWD $ do
697 valueRef :: IORef Text <- newRef ""
683 valueRef :: IORef Text <- newRef ""
698− let checkValue = readRef valueRef >>= flip shouldBe "one"
684+ let checkValue = readRef valueRef `shouldBeWithRetryM` "one"
699 testWidget (pure ()) checkValue $ do
685 testWidget (pure ()) checkValue $ do
700 prerender_ (pure ()) $ do
686 prerender_ (pure ()) $ do
701 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
687 (e, ()) <- selectElement def { _selectElementConfig_initialValue = "one" } options
@@ -705,14 +691,12 @@ tests wdConfig caps _selenium = do
705 valueRef :: IORef Text <- newRef ""
691 valueRef :: IORef Text <- newRef ""
706 setValueChan :: Chan Text <- liftIO newChan
692 setValueChan :: Chan Text <- liftIO newChan
707 let checkValue = do
693 let checkValue = do
708− WD.click <=< WD.findElem $ WD.ById "two"
694+ WD.click =<< findElemWithRetry (WD.ById "two")
709− liftIO $ threadDelay 100000
710− readRef valueByUIRef >>= flip shouldBe "two"
695+ readRef valueByUIRef `shouldBeWithRetryM` "two"
711− readRef valueRef >>= flip shouldBe "two"
696+ readRef valueRef `shouldBeWithRetryM` "two"
712 liftIO $ writeChan setValueChan "three"
697 liftIO $ writeChan setValueChan "three"
713− liftIO $ threadDelay 100000
714− readRef valueByUIRef >>= flip shouldBe "two"
698+ readRef valueByUIRef `shouldBeWithRetryM` "two"
715− readRef valueRef >>= flip shouldBe "three"
699+ readRef valueRef `shouldBeWithRetryM` "three"
716 testWidget (pure ()) checkValue $ do
700 testWidget (pure ()) checkValue $ do
717 setValue' <- triggerEventWithChan setValueChan
701 setValue' <- triggerEventWithChan setValueChan
718 prerender_ (pure ()) $ do
702 prerender_ (pure ()) $ do
@@ -725,7 +709,7 @@ tests wdConfig caps _selenium = do
725 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
709 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
726 prerender_ (text "One") (text "Two")
710 prerender_ (text "One") (text "Two")
727 it "removes element correctly" $ runWD $ do
711 it "removes element correctly" $ runWD $ do
728− testWidget' (WD.findElem $ WD.ByTag "span") elementShouldBeRemoved $ do
712+ testWidget' (findElemWithRetry $ WD.ByTag "span") elementShouldBeRemoved $ do
729 prerender_ (el "span" $ text "One") (text "Two")
713 prerender_ (el "span" $ text "One") (text "Two")
730 it "can be nested in server widget" $ runWD $ do
714 it "can be nested in server widget" $ runWD $ do
731 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
715 testWidget (checkBodyText "One") (checkBodyText "Three") $ do
@@ -765,8 +749,8 @@ tests wdConfig caps _selenium = do
765 pb <- getPostBuild
749 pb <- getPostBuild
766 performEvent_ $ liftIO (putMVar lock ()) <$ pb
750 performEvent_ $ liftIO (putMVar lock ()) <$ pb
767 it "result Dynamic is updated *after* switchover" $ runWD $ do
751 it "result Dynamic is updated *after* switchover" $ runWD $ do
768− let static = shouldContainText "PostBuild" =<< WD.findElem (WD.ByTag "body")
752+ let static = checkBodyText "PostBuild"
769− check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
753+ check = checkBodyText "Client"
770 testWidget static check $ void $ do
754 testWidget static check $ void $ do
771 d <- prerender (pure "Initial") (pure "Client")
755 d <- prerender (pure "Initial") (pure "Client")
772 pb <- getPostBuild
756 pb <- getPostBuild
@@ -775,15 +759,15 @@ tests wdConfig caps _selenium = do
775 -- This essentially checks that the client IO runs *after* switchover/postBuild,
759 -- This essentially checks that the client IO runs *after* switchover/postBuild,
776 -- thus can't create conflicting DOM
760 -- thus can't create conflicting DOM
777 it "can't exploit IO to break hydration" $ runWD $ do
761 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"
779 testWidgetStatic static $ void $ do
763 testWidgetStatic static $ void $ do
780 ref <- liftIO $ newRef "Initial"
764 ref <- liftIO $ newRef "Initial"
781 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
765 prerender_ (pure ()) (liftIO $ writeRef ref "Client")
782 text <=< liftIO $ readRef ref
766 text <=< liftIO $ readRef ref
783 -- As above, so below
767 -- As above, so below
784 it "can't exploit triggerEvent to break hydration" $ runWD $ do
768 it "can't exploit triggerEvent to break hydration" $ runWD $ do
785− let static = shouldContainText "Initial" =<< WD.findElem (WD.ByTag "body")
769+ let static = checkBodyText "Initial"
786− check = shouldContainText "Client" =<< WD.findElem (WD.ByTag "body")
770+ check = checkBodyText "Client"
787 testWidget static check $ void $ do
771 testWidget static check $ void $ do
788 (e, trigger) <- newTriggerEvent
772 (e, trigger) <- newTriggerEvent
789 prerender_ (pure ()) (liftIO $ trigger "Client")
773 prerender_ (pure ()) (liftIO $ trigger "Client")
@@ -792,15 +776,13 @@ tests wdConfig caps _selenium = do
792 describe "runWithReplace" $ session' $ do
776 describe "runWithReplace" $ session' $ do
793 it "works" $ runWD $ do
777 it "works" $ runWD $ do
794 replaceChan :: Chan Text <- liftIO newChan
778 replaceChan :: Chan Text <- liftIO newChan
795− let setup = WD.findElem $ WD.ByTag "div"
779+ let setup = findElemWithRetry $ WD.ByTag "div"
796 check ssr = do
780 check ssr = do
797 -- Check that the original element still exists and has the correct text
781 -- Check that the original element still exists and has the correct text
798− WD.getText ssr >>= flip shouldBe "two"
782+ shouldContainText "two" ssr
800− writeChan replaceChan "three"
783+ liftIO $ writeChan replaceChan "three"
802 elementShouldBeRemoved ssr
784 elementShouldBeRemoved ssr
803− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
785+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
804 testWidget' setup check $ do
786 testWidget' setup check $ do
805 replace <- triggerEventWithChan replaceChan
787 replace <- triggerEventWithChan replaceChan
806 pb <- getPostBuild
788 pb <- getPostBuild
@@ -810,15 +792,13 @@ tests wdConfig caps _selenium = do
811 it "can be nested in initial widget" $ runWD $ do
793 it "can be nested in initial widget" $ runWD $ do
812 replaceChan :: Chan Text <- liftIO newChan
794 replaceChan :: Chan Text <- liftIO newChan
813− let setup = WD.findElem $ WD.ByTag "div"
795+ let setup = findElemWithRetry $ WD.ByTag "div"
814 check ssr = do
796 check ssr = do
815 -- Check that the original element still exists and has the correct text
797 -- Check that the original element still exists and has the correct text
816− WD.getText ssr >>= flip shouldBe "two"
798+ shouldContainText "two" ssr
818− writeChan replaceChan "three"
799+ liftIO $ writeChan replaceChan "three"
820 elementShouldBeRemoved ssr
800 elementShouldBeRemoved ssr
821− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
801+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
822 testWidget' setup check $ void $ flip runWithReplace never $ do
802 testWidget' setup check $ void $ flip runWithReplace never $ do
823 replace <- triggerEventWithChan replaceChan
803 replace <- triggerEventWithChan replaceChan
824 pb <- getPostBuild
804 pb <- getPostBuild
@@ -828,15 +808,13 @@ tests wdConfig caps _selenium = do
829 it "can be nested in postBuild widget" $ runWD $ do
809 it "can be nested in postBuild widget" $ runWD $ do
830 replaceChan <- liftIO newChan
810 replaceChan <- liftIO newChan
831− let setup = WD.findElem $ WD.ByTag "div"
811+ let setup = findElemWithRetry $ WD.ByTag "div"
832 check ssr = do
812 check ssr = do
833 -- Check that the original element still exists and has the correct text
813 -- Check that the original element still exists and has the correct text
834− WD.getText ssr >>= flip shouldBe "two"
814+ shouldContainText "two" ssr
836− writeChan replaceChan "three"
815+ liftIO $ writeChan replaceChan "three"
838 elementShouldBeRemoved ssr
816 elementShouldBeRemoved ssr
839− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
817+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
840 testWidget' setup check $ void $ do
818 testWidget' setup check $ void $ do
841 pb <- getPostBuild
819 pb <- getPostBuild
842 runWithReplace (pure ()) $ ffor pb $ \() -> do
820 runWithReplace (pure ()) $ ffor pb $ \() -> do
@@ -862,17 +840,15 @@ tests wdConfig caps _selenium = do
862 replaceChan2 :: Chan Text <- liftIO newChan
840 replaceChan2 :: Chan Text <- liftIO newChan
863 lock :: MVar () <- liftIO newEmptyMVar
841 lock :: MVar () <- liftIO newEmptyMVar
864 let check = do
842 let check = do
865− shouldContainText "" =<< WD.findElem (WD.ByTag "body")
843+ shouldContainText "" =<< (findElemWithRetry (WD.ByTag "body"))
866 liftIO $ do
844 liftIO $ do
867 writeChan replaceChan1 "one"
845 writeChan replaceChan1 "one"
868 takeMVar lock
846 takeMVar lock
869− one <- WD.findElem $ WD.ByTag "div"
847+ one <- findElemWithRetry $ WD.ByTag "div"
870− WD.getText one >>= flip shouldBe "pb"
848+ shouldContainText "pb" one
872− writeChan replaceChan2 "two"
849+ liftIO $ writeChan replaceChan2 "two"
874 elementShouldBeRemoved one
850 elementShouldBeRemoved one
875− shouldContainText "two" =<< WD.findElem (WD.ByTag "span")
851+ shouldContainText "two" =<< findElemWithRetry (WD.ByTag "span")
876 testWidget (pure ()) check $ void $ do
852 testWidget (pure ()) check $ void $ do
877 replace1 <- triggerEventWithChan replaceChan1
853 replace1 <- triggerEventWithChan replaceChan1
878 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
854 runWithReplace (pure ()) $ ffor replace1 $ \r1 -> do
@@ -913,14 +889,12 @@ tests wdConfig caps _selenium = do
913 it "works in immediate mode (RHS of prerender)" $ runWD $ do
889 it "works in immediate mode (RHS of prerender)" $ runWD $ do
914 replaceChan :: Chan Text <- liftIO newChan
890 replaceChan :: Chan Text <- liftIO newChan
915 let check = do
891 let check = do
916− one <- WD.findElem $ WD.ByTag "div"
893+ one <- findElemWithRetry $ WD.ByTag "div"
917− shouldContainText "one" =<< WD.findElem (WD.ByTag "body")
894+ shouldContainText "one" one
918− WD.getText one >>= flip shouldBe "one"
920− writeChan replaceChan "pb"
895+ liftIO $ writeChan replaceChan "pb"
922 elementShouldBeRemoved one
896 elementShouldBeRemoved one
923− shouldContainText "pb" =<< WD.findElem (WD.ByTag "span")
897+ shouldContainText "pb" =<< findElemWithRetry (WD.ByTag "span")
924 testWidget (pure ()) check $ void $ do
898 testWidget (pure ()) check $ void $ do
925 replace <- triggerEventWithChan replaceChan
899 replace <- triggerEventWithChan replaceChan
926 prerender_ blank $ do
900 prerender_ blank $ do
@@ -928,14 +902,12 @@ tests wdConfig caps _selenium = do
928 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
902 it "works with postBuild in immediate mode (RHS of prerender)" $ runWD $ do
929 replaceChan :: Chan Text <- liftIO newChan
903 replaceChan :: Chan Text <- liftIO newChan
930 let check = do
904 let check = do
931− two <- WD.findElem $ WD.ByTag "div"
906+ two <- findElemWithRetry $ WD.ByTag "div"
932− shouldContainText "two" =<< WD.findElem (WD.ByTag "body")
907+ shouldContainText "two" two
933− WD.getText two >>= flip shouldBe "two"
935− writeChan replaceChan "three"
908+ liftIO $ writeChan replaceChan "three"
937 elementShouldBeRemoved two
909 elementShouldBeRemoved two
938− shouldContainText "three" =<< WD.findElem (WD.ByTag "span")
910+ shouldContainText "three" =<< findElemWithRetry (WD.ByTag "span")
939 testWidget (pure ()) check $ void $ do
911 testWidget (pure ()) check $ void $ do
940 replace <- triggerEventWithChan replaceChan
912 replace <- triggerEventWithChan replaceChan
941 prerender_ blank $ do
913 prerender_ blank $ do
@@ -953,34 +925,34 @@ tests wdConfig caps _selenium = do
953 pure (Identity v)
925 pure (Identity v)
954 checkItem :: WD.Element -> Text -> Text -> WD ()
926 checkItem :: WD.Element -> Text -> Text -> WD ()
955 checkItem li k v = do
927 checkItem li k v = do
928+ putStrLnDebug "checkItem"
956− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
929+ shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
957− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
930+ shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
958 checkInitialItems dm xs = do
931 checkInitialItems dm xs = do
932+ putStrLnDebug "checkInitialItems"
959 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
933 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
960 forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey k) (T.pack $ has @Show k $ show v)
934 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"
962 xs <- WD.findElems (WD.ByTag "li")
937 xs <- WD.findElems (WD.ByTag "li")
963 checkInitialItems dm xs
938 checkInitialItems dm xs
965 checkRemoval chan k = do
940 checkRemoval chan k = do
941+ putStrLnDebug "checkRemoval"
966− e <- WD.findElem (WD.ById $ textKey k)
942+ e <- findElemWithRetry (WD.ById $ textKey k)
968− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
943+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe Nothing)
970 elementShouldBeRemoved e
944 elementShouldBeRemoved e
971 checkReplace chan k v = do
945 checkReplace chan k v = do
946+ putStrLnDebug "checkReplace"
972− e <- WD.findElem (WD.ById $ textKey k)
947+ e <- findElemWithRetry (WD.ById $ textKey k)
974− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
948+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
976 elementShouldBeRemoved e
949 elementShouldBeRemoved e
977− e' <- WD.findElem (WD.ById $ textKey k)
950+ e' <- findElemWithRetry $ WD.ById $ textKey k
978 checkItem e' (textKey k) (T.pack $ show v)
951 checkItem e' (textKey k) (T.pack $ show v)
979 checkInsert chan k v = do
952 checkInsert chan k v = do
980− liftIO $ do
953+ putStrLnDebug "checkInsert"
981− writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
954+ liftIO $ writeChan chan $ PatchDMap $ DMap.singleton k (ComposeMaybe $ Just $ Identity v)
983− e <- WD.findElem (WD.ById $ textKey k)
955+ e <- findElemWithRetry (WD.ById $ textKey k)
984 checkItem e (textKey k) (T.pack $ show v)
956 checkItem e (textKey k) (T.pack $ show v)
985 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
957 postBuildPatch = PatchDMap $ DMap.fromList [Key_Char :=> ComposeMaybe Nothing, Key_Bool :=> ComposeMaybe (Just $ Identity True)]
986 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
958 it "doesn't replace elements at switchover, can delete/update/insert" $ runWD $ do
@@ -998,9 +970,9 @@ tests wdConfig caps _selenium = do
998 liftIO $ dmap `H.shouldBe` keyMap
970 liftIO $ dmap `H.shouldBe` keyMap
999 it "handles postBuild correctly" $ runWD $ do
971 it "handles postBuild correctly" $ runWD $ do
1000 chan <- liftIO newChan
972 chan <- liftIO newChan
1001− let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
973+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1002 check xs = do
974 check xs = do
1003− checkInitialItems (fromMaybe undefined $ apply postBuildPatch keyMap) xs
975+ withRetry $ checkInitialItems (applyAlways postBuildPatch keyMap) xs
1004 checkRemoval chan Key_Int
976 checkRemoval chan Key_Int
1005 checkInsert chan Key_Char 'B'
977 checkInsert chan Key_Char 'B'
1006 checkReplace chan Key_Bool True
978 checkReplace chan Key_Bool True
@@ -1037,7 +1009,7 @@ tests wdConfig caps _selenium = do
1037 it "handles postBuild correctly in prerender" $ runWD $ do
1009 it "handles postBuild correctly in prerender" $ runWD $ do
1038 chan <- liftIO newChan
1010 chan <- liftIO newChan
1039 let check = do
1011 let check = do
1040− _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch keyMap)
1012+ _ <- getAndCheckInitialItems $ applyAlways postBuildPatch keyMap
1041 checkRemoval chan Key_Int
1013 checkRemoval chan Key_Int
1042 checkInsert chan Key_Char 'B'
1014 checkInsert chan Key_Char 'B'
1043 checkReplace chan Key_Bool True
1015 checkReplace chan Key_Bool True
@@ -1062,37 +1034,37 @@ tests wdConfig caps _selenium = do
1063 checkItem :: WD.Element -> Text -> Text -> WD ()
1035 checkItem :: WD.Element -> Text -> Text -> WD ()
1064 checkItem li k v = do
1036 checkItem li k v = do
1037+ putStrLnDebug "checkItem"
1065− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1038+ shouldContainTextNoRetry k =<< WD.findElemFrom li (WD.ByClass "key")
1066− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1039+ shouldContainTextNoRetry v =<< WD.findElemFrom li (WD.ByClass "value")
1067 checkInitialItems dm xs = do
1040 checkInitialItems dm xs = do
1041+ putStrLnDebug "checkInitialItems"
1068 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
1042 liftIO $ assertEqual "Wrong amount of items in DOM" (IntMap.size dm) (length xs)
1069 forM_ (zip xs (IntMap.toList dm)) $ \(e, (k, v)) -> checkItem e (textKeyInt k) v
1043 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"
1071 xs <- WD.findElems (WD.ByTag "li")
1046 xs <- WD.findElems (WD.ByTag "li")
1072 checkInitialItems dm xs
1047 checkInitialItems dm xs
1074 checkRemoval chan k = do
1049 checkRemoval chan k = do
1050+ putStrLnDebug "checkRemoval"
1075− e <- WD.findElem (WD.ById $ textKeyInt k)
1051+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
1077− writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1052+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k Nothing
1079 elementShouldBeRemoved e
1053 elementShouldBeRemoved e
1080 checkReplace chan k v = do
1054 checkReplace chan k v = do
1055+ putStrLnDebug "checkReplace"
1081− e <- WD.findElem (WD.ById $ textKeyInt k)
1056+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
1083− writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1057+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1085 elementShouldBeRemoved e
1058 elementShouldBeRemoved e
1086− e' <- WD.findElem (WD.ById $ textKeyInt k)
1059+ e' <- findElemWithRetry (WD.ById $ textKeyInt k)
1087− checkItem e' (textKeyInt k) v
1060+ withRetry $ checkItem e' (textKeyInt k) v
1088 checkInsert chan k v = do
1061 checkInsert chan k v = do
1089− liftIO $ do
1062+ putStrLnDebug "checkInsert"
1090− writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1063+ liftIO $ writeChan chan $ PatchIntMap $ IntMap.singleton k $ Just v
1092− e <- WD.findElem (WD.ById $ textKeyInt k)
1064+ e <- findElemWithRetry (WD.ById $ textKeyInt k)
1093 checkItem e (textKeyInt k) v
1065 checkItem e (textKeyInt k) v
1094 postBuildPatch = PatchIntMap $ IntMap.fromList [(2, Nothing), (3, Just "trois"), (4, Just "four")]
1066 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
1096 chan <- liftIO newChan
1068 chan <- liftIO newChan
1097 let static = getAndCheckInitialItems intMap
1069 let static = getAndCheckInitialItems intMap
1098 check xs = do
1070 check xs = do
@@ -1103,11 +1075,11 @@ tests wdConfig caps _selenium = do
1103 testWidget' static check $ void $ do
1075 testWidget' static check $ void $ do
1104 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1076 (im, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1105 liftIO $ im `H.shouldBe` intMap
1077 liftIO $ im `H.shouldBe` intMap
1106− it "handles postBuild correctly" $ runWD $ do
1078+ xit "handles postBuild correctly" $ runWD $ do
1107 chan <- liftIO newChan
1079 chan <- liftIO newChan
1108− let static = getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1080+ let static = getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1109 check xs = do
1081 check xs = do
1110− checkInitialItems (fromMaybe undefined $ apply postBuildPatch intMap) xs
1082+ withRetry $ checkInitialItems (applyAlways postBuildPatch intMap) xs
1111 checkRemoval chan 1
1083 checkRemoval chan 1
1112 checkInsert chan 2 "deux"
1084 checkInsert chan 2 "deux"
1113 checkReplace chan 3 "trois"
1085 checkReplace chan 3 "trois"
@@ -1116,35 +1088,35 @@ tests wdConfig caps _selenium = do
1116 replace <- triggerEventWithChan chan
1088 replace <- triggerEventWithChan chan
1117 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1089 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1118 liftIO $ dmap `H.shouldBe` intMap
1090 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
1120 chan <- liftIO newChan
1092 chan <- liftIO newChan
1121 let check = do
1093 let check = do
1122 _ <- getAndCheckInitialItems intMap
1094 _ <- getAndCheckInitialItems intMap
1123 checkRemoval chan 1
1095 checkRemoval chan 1
1124 checkReplace chan 2 "deux"
1096 checkReplace chan 2 "deux"
1125− checkInsert chan 3 "trois"
1097+ checkInsert chan 4 "quatre"
1126 testWidget (pure ()) check $ do
1098 testWidget (pure ()) check $ do
1127 replace <- triggerEventWithChan chan
1099 replace <- triggerEventWithChan chan
1128 prerender_ (pure ()) $ do
1100 prerender_ (pure ()) $ do
1129 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
1101 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap replace
1130 liftIO $ dmap `H.shouldBe` intMap
1102 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
1132 chan <- liftIO newChan
1104 chan <- liftIO newChan
1133 let check = do
1105 let check = do
1134 _ <- getAndCheckInitialItems intMap
1106 _ <- getAndCheckInitialItems intMap
1135 checkRemoval chan 1
1107 checkRemoval chan 1
1136 checkReplace chan 2 "deux"
1108 checkReplace chan 2 "deux"
1137− checkInsert chan 3 "trois"
1109+ checkInsert chan 4 "quatre"
1138 testWidget (pure ()) check $ void $ do
1110 testWidget (pure ()) check $ void $ do
1139 pb <- getPostBuild
1111 pb <- getPostBuild
1140 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1112 runWithReplace (pure ()) $ ffor pb $ \() -> void $ do
1141 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1113 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap =<< triggerEventWithChan chan
1142 liftIO $ dmap `H.shouldBe` intMap
1114 liftIO $ dmap `H.shouldBe` intMap
1143 -- Should be fixed by prerender changes!
1115 -- Should be fixed by prerender changes!
1144− it "handles postBuild correctly in prerender" $ runWD $ do
1116+ xit "handles postBuild correctly in prerender" $ runWD $ do
1145 chan <- liftIO newChan
1117 chan <- liftIO newChan
1146 let check = do
1118 let check = do
1147− _ <- getAndCheckInitialItems (fromJust $ apply postBuildPatch intMap)
1119+ _ <- getAndCheckInitialItems $ applyAlways postBuildPatch intMap
1148 checkRemoval chan 1
1120 checkRemoval chan 1
1149 checkInsert chan 2 "deux"
1121 checkInsert chan 2 "deux"
1150 checkReplace chan 3 "trois"
1122 checkReplace chan 3 "trois"
@@ -1157,45 +1129,25 @@ tests wdConfig caps _selenium = do
1158 describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1130 describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1159 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1131 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1160− widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1132+ widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1161− elClass "span" "key" $ text $ textKey k
1133+ elClass "span" "key" $ text $ textKey2 k
1162 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
1134 elClass "span" "value" $ text $ T.pack $ has @Show k $ show v
1163 pure (Identity v)
1135 pure (Identity v)
1164− textKey :: Key2 a -> Text
1136+ textKey2 :: Key2 a -> Text
1165− textKey = \case
1137+ textKey2 = \case
1166 Key2_Int i -> "i" <> T.pack (show i)
1138 Key2_Int i -> "i" <> T.pack (show i)
1167 Key2_Char c -> "c" <> T.pack [c]
1139 Key2_Char c -> "c" <> T.pack [c]
1168 checkItem :: WD.Element -> Text -> Text -> WD ()
1140 checkItem :: WD.Element -> Text -> Text -> WD ()
1169 checkItem li k v = do
1141 checkItem li k v = do
1170− shouldContainText k =<< WD.findElemFrom li (WD.ByClass "key")
1142+ shouldContainTextNoRetry k =<< (WD.findElemFrom li (WD.ByClass "key"))
1171− shouldContainText v =<< WD.findElemFrom li (WD.ByClass "value")
1143+ shouldContainTextNoRetry v =<< (WD.findElemFrom li (WD.ByClass "value"))
1172 checkInitialItems dm xs = do
1144 checkInitialItems dm xs = do
1173 liftIO $ assertEqual "Wrong amount of items in DOM" (DMap.size dm) (length xs)
1145 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)
1146+ forM_ (zip xs (DMap.toList dm)) $ \(e, k :=> Identity v) -> checkItem e (textKey2 k) (T.pack $ has @Show k $ show v)
1175− getAndCheckInitialItems dm = do
1147+ getAndCheckInitialItems dm = withRetry $ do
1176 xs <- WD.findElems (WD.ByTag "li")
1148 xs <- WD.findElems (WD.ByTag "li")
1177 checkInitialItems dm xs
1149 checkInitialItems dm xs
1179− checkRemoval chan k = do
1180− e <- WD.findElem (WD.ById $ textKey k)
1182− writeChan chan $ deleteDMapKey k
1184− elementShouldBeRemoved e
1185− checkReplace chan k v = do
1186− e <- WD.findElem (WD.ById $ textKey k)
1188− writeChan chan $ insertDMapKey k (Identity v)
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
1195− writeChan chan $ insertDMapKey k (Identity v)
1197− e <- WD.findElem (WD.ById $ textKey k)
1198− checkItem e (textKey k) (T.pack $ show v)
1199 moveSpec testMove = do
1151 moveSpec testMove = do
1200 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1152 it "can insert an item" $ runWD $ testMove (DMap.fromList [Key2_Int 1 ==> 1, Key2_Int 3 ==> 3]) $ \body chan -> do
1201 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
1153 shouldContainText (T.strip $ T.unlines ["i11","i33"]) body
@@ -1226,7 +1178,7 @@ tests wdConfig caps _selenium = do
1226 let static = getAndCheckInitialItems initMap
1178 let static = getAndCheckInitialItems initMap
1227 check xs = do
1179 check xs = do
1228 checkInitialItems initMap xs
1180 checkInitialItems initMap xs
1229− body <- WD.findElem (WD.ByTag "body")
1181+ body <- getBody
1230 test body chan
1182 test body chan
1231 testWidget' static check $ void $ do
1183 testWidget' static check $ void $ do
1232 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1184 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
@@ -1242,7 +1194,7 @@ tests wdConfig caps _selenium = do
1242 takeMVar lock
1194 takeMVar lock
1243 xs <- getAndCheckInitialItems initMap
1195 xs <- getAndCheckInitialItems initMap
1244 checkInitialItems initMap xs
1196 checkInitialItems initMap xs
1245− body <- WD.findElem (WD.ByTag "body")
1197+ body <- getBody
1246 test body chan
1198 test body chan
1247 testWidget (pure ()) check $ void $ do
1199 testWidget (pure ()) check $ void $ do
1248 e <- triggerEventWithChan replace
1200 e <- triggerEventWithChan replace
@@ -1255,17 +1207,16 @@ tests wdConfig caps _selenium = do
1255 describe "hydrating invalid HTML" $ session' $ do
1207 describe "hydrating invalid HTML" $ session' $ do
1256 it "can hydrate list in paragraph" $ runWD $ do
1208 it "can hydrate list in paragraph" $ runWD $ do
1257 let static = do
1209 let static = do
1258− body <- WD.findElem (WD.ByTag "body")
1259− shouldContainText "before\ninner\nafter" body
1210+ checkBodyText "before\ninner\nafter"
1260 -- Two <p> tags should be present
1211 -- Two <p> tags should be present
1261 [p1, p2] <- WD.findElems (WD.ByTag "p")
1212 [p1, p2] <- WD.findElems (WD.ByTag "p")
1262− ol <- WD.findElem (WD.ByTag "ol")
1213+ ol <- findElemWithRetry (WD.ByTag "ol")
1263 shouldContainText "before" p1
1214 shouldContainText "before" p1
1264 shouldContainText "inner" ol
1215 shouldContainText "inner" ol
1265 shouldContainText "" p2
1216 shouldContainText "" p2
1266− pure (body, p1, ol, p2)
1217+ pure (p1, ol, p2)
1267− check (body, p1, ol, p2) = do
1218+ check (p1, ol, p2) = do
1268− shouldContainText "before\ninner\nafter" body
1219+ checkBodyText "before\ninner\nafter"
1269 shouldContainText "before\ninner\nafter" p1
1220 shouldContainText "before\ninner\nafter" p1
1270 elementShouldBeRemoved ol
1221 elementShouldBeRemoved ol
1271 elementShouldBeRemoved p2
1222 elementShouldBeRemoved p2
@@ -1293,11 +1244,10 @@ startSeleniumServer port = do
1294withSeleniumServer :: (Selenium -> IO ()) -> IO ()
1245withSeleniumServer :: (Selenium -> IO ()) -> IO ()
1295withSeleniumServer f = do
1246withSeleniumServer f = do
1296− port <- getFreePort
1297− stopServer <- startSeleniumServer port
1247+ stopServer <- startSeleniumServer seleniumPort
1298 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1248 threadDelay $ 1000 * 1000 * 2 -- TODO poll or wait on a a signal to block on
1299 f $ Selenium
1249 f $ Selenium
1300− { _selenium_portNumber = port
1250+ { _selenium_portNumber = seleniumPort
1301 , _selenium_stopServer = stopServer
1251 , _selenium_stopServer = stopServer
@@ -1308,122 +1258,152 @@ triggerEventWithChan chan = do
1308 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
1258 prerender_ (pure ()) $ void $ liftIO $ forkIO $ forever $ trigger =<< readChan chan
1261+shouldBeWithRetryM :: (Eq a, Show a) => WD a -> a -> WD ()
1262+shouldBeWithRetryM m expected = withRetry $ do
1264+ got `shouldBe` expected
1311assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
1266assertAttr :: WD.Element -> Text -> Maybe Text -> WD ()
1312assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
1267assertAttr e k v = liftIO . assertEqual "Incorrect attribute value" v =<< WD.attr e k
1314elementShouldBeRemoved :: WD.Element -> WD ()
1269elementShouldBeRemoved :: WD.Element -> WD ()
1315−elementShouldBeRemoved e = do
1270+elementShouldBeRemoved e = withRetry $ do
1316 try (WD.getText e) >>= \case
1271 try (WD.getText e) >>= \case
1317 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
1272 Left (WD.FailedCommand WD.StaleElementReference _) -> return ()
1318 Left err -> throwM err
1273 Left err -> throwM err
1319 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
1274 Right !_ -> liftIO $ assertFailure "Expected element to be removed, but it still exists"
1321shouldContainText :: Text -> WD.Element -> WD ()
1276shouldContainText :: Text -> WD.Element -> WD ()
1277+shouldContainText t = withRetry . shouldContainTextNoRetry t
1279+shouldContainTextNoRetry :: Text -> WD.Element -> WD ()
1322−shouldContainText t = flip shouldBe t <=< WD.getText
1280+shouldContainTextNoRetry t = flip shouldBe t <=< WD.getText
1324checkBodyText :: Text -> WD ()
1282checkBodyText :: Text -> WD ()
1325checkBodyText = checkTextInTag "body"
1283checkBodyText = checkTextInTag "body"
1327checkTextInTag :: Text -> Text -> WD ()
1285checkTextInTag :: Text -> Text -> WD ()
1286+checkTextInTag t expected = do
1287+ e <- findElemWithRetry (WD.ByTag t)
1328−checkTextInTag t expected = WD.findElem (WD.ByTag t) >>= shouldContainText expected
1288+ shouldContainText expected e
1330checkTextInId :: Text -> Text -> WD ()
1290checkTextInId :: 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
1295+findElemWithRetry :: Selector -> WD WD.Element
1296+findElemWithRetry = withRetry . WD.findElem
1298+getBody :: WD WD.Element
1299+getBody = WD.findElem $ WD.ByTag "body"
1301+withRetry :: forall a. WD a -> WD a
1302+withRetry a = wait 300
1303+ where wait :: Int -> WD a
1305+ wait n = try a >>= \case
1306+ Left (_ :: SomeException) -> do
1307+ liftIO $ threadDelay 100000
1309+ Right v -> return v
1333divId :: DomBuilder t m => Text -> m a -> m a
1311divId :: DomBuilder t m => Text -> m a -> m a
1334divId i = elAttr "div" ("id" =: i)
1312divId i = elAttr "div" ("id" =: i)
1336type 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)
1314type 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)
1338−testWidgetStatic
1316+testWidgetStaticDebug
1339− :: WD b
1318+ -> WD b
1340 -- ^ Webdriver commands to run before JS runs and after hydration switchover
1319 -- ^ Webdriver commands to run before JS runs and after hydration switchover
1341 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1320 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1342 -- ^ Widget we are testing
1321 -- ^ Widget we are testing
1344−testWidgetStatic w = testWidget (void w) w
1323+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1346-- | TODO: do something about JSExceptions not causing tests to fail
1325-- | TODO: do something about JSExceptions not causing tests to fail
1347−testWidget
1326+testWidgetDebug
1348− :: WD ()
1328+ -> WD ()
1349 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1329 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1351 -- ^ Webdriver commands to run after hydration switchover
1331 -- ^ Webdriver commands to run after hydration switchover
1352 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1332 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1353 -- ^ Widget we are testing
1333 -- ^ Widget we are testing
1335+testWidgetDebug withDebugging beforeJS afterSwitchover =
1355−testWidget beforeJS afterSwitchover = testWidget' beforeJS (const afterSwitchover)
1336+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1357-- | TODO: do something about JSExceptions not causing tests to fail
1338-- | TODO: do something about JSExceptions not causing tests to fail
1358−testWidget'
1339+testWidgetDebug'
1359− :: WD a
1341+ -> WD a
1360 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1342 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1361 -> (a -> WD b)
1343 -> (a -> WD b)
1362 -- ^ Webdriver commands to run after hydration switchover
1344 -- ^ Webdriver commands to run after hydration switchover
1363 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1345 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1364 -- ^ Widget we are testing (contents of body)
1346 -- ^ Widget we are testing (contents of body)
1366−testWidget' beforeJS afterSwitchover bodyWidget = maybe (error "test timed out") pure <=< timeout testTimeLimit $ 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
1367− let staticApp = do
1351+ staticApp = do
1368 el "head" $ pure ()
1352 el "head" $ pure ()
1369 el "body" $ do
1353 el "body" $ do
1370 bodyWidget
1354 bodyWidget
1371 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1355 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1356+ putStrLnDebug "rendering static"
1372 ((), html) <- liftIO $ renderStatic staticApp
1357 ((), html) <- liftIO $ renderStatic staticApp
1358+ putStrLnDebug "rendered static"
1373 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1359 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1374 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1360 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1375 let entryPoint = do
1361 let entryPoint = do
1362+ putStrLnDebug "taking waitBeforeJS"
1376 liftIO $ takeMVar waitBeforeJS
1363 liftIO $ takeMVar waitBeforeJS
1364+ let switchOverAction = do
1365+ putStrLnDebug "switchover syncPoint"
1367+ putStrLnDebug "putting waitUntilSwitchover"
1377− mainHydrationWidgetWithSwitchoverAction (liftIO $ putMVar waitUntilSwitchover ()) (pure ()) bodyWidget
1368+ liftIO $ putMVar waitUntilSwitchover ()
1369+ putStrLnDebug "put waitUntilSwitchover"
1370+ putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1371+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1372+ putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1378 syncPoint
1373 syncPoint
1379− application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse ->
1374+ application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1375+ putStrLnDebug "sending response"
1380− sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1376+ r <- sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1381− port <- getFreePort
1377+ putStrLnDebug "sent response"
1382 waitJSaddle <- liftIO newEmptyMVar
1379 waitJSaddle <- liftIO newEmptyMVar
1383 let settings = foldr ($) Warp.defaultSettings
1380 let settings = foldr ($) Warp.defaultSettings
1384− [ Warp.setPort $ fromIntegral (toInteger port)
1381+ [ Warp.setPort $ fromIntegral $ toInteger jsaddlePort
1385− , Warp.setBeforeMainLoop $ putMVar waitJSaddle ()
1382+ , Warp.setBeforeMainLoop $ do
1383+ putStrLnDebug "putting waitJSaddle"
1384+ putMVar waitJSaddle ()
1385+ putStrLnDebug "put waitJSaddle"
1387 -- hSilence to get rid of ConnectionClosed logs
1387 -- hSilence to get rid of ConnectionClosed logs
1388+ silenceIfDebug = if withDebugging then id else hSilence [stderr]
1388− jsaddleWarp = forkIO $ hSilence [stderr] $ Warp.runSettings settings application
1389+ jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1389 jsaddleTid <- liftIO jsaddleWarp
1390 jsaddleTid <- liftIO jsaddleWarp
1391+ putStrLnDebug "taking waitJSaddle"
1390 liftIO $ takeMVar waitJSaddle
1392 liftIO $ takeMVar waitJSaddle
1393+ putStrLnDebug "opening page"
1391− WD.openPage $ "http://localhost:" <> show port
1394+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1395+ putStrLnDebug "running beforeJS"
1392 a <- beforeJS
1396 a <- beforeJS
1397+ putStrLnDebug "putting waitBeforeJS"
1393 liftIO $ putMVar waitBeforeJS ()
1398 liftIO $ putMVar waitBeforeJS ()
1399+ putStrLnDebug "taking waitUntilSwitchover"
1394 liftIO $ takeMVar waitUntilSwitchover
1400 liftIO $ takeMVar waitUntilSwitchover
1395− liftIO $ threadDelay 100000 -- wait a bit
1401+ putStrLnDebug "running afterSwitchover"
1396 b <- afterSwitchover a
1402 b <- afterSwitchover a
1403+ putStrLnDebug "killing jsaddle thread"
1397 liftIO $ killThread jsaddleTid
1404 liftIO $ killThread jsaddleTid
1398 return b
1405 return b
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
1409− sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
1410− bind sock (addrAddress addr)
1413−testWidgetDebug :: MonadIO n => (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> n ()
1414−testWidgetDebug bodyWidget = liftIO $ do
1416− el "head" $ pure ()
1419− el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1420− ((), html) <- renderStatic staticApp
1421− let entryPoint = do
1422− mainHydrationWidgetWithSwitchoverAction (pure ()) (pure ()) bodyWidget
1424− application <- jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> sendResponse $ responseLBS status200 [] $ "<!doctype html>\n" <> LBS.fromStrict html
1425− Warp.runSettings (Warp.setPort 3911 Warp.defaultSettings) application
1427data Key2 a where
1407data Key2 a where
1428 Key2_Int :: Int -> Key2 Int
1408 Key2_Int :: Int -> Key2 Int
1429 Key2_Char :: Char -> Key2 Char
1409 Key2_Char :: Char -> Key2 Char