@@ -20,6 +20,14 @@
2020
2121{-# OPTIONS_GHC -fno-warn-orphans #-}
2222
23+-- Notice to those working on this test suite:
24+-- It doesn't appear to be possible to use --match to run a particular test, in
25+-- this situation the test may hang before reaching our code. This seems to
26+-- happen when the test is not the first test in the block. As a workaround, you
27+-- can just comment out the other tests. Also, using `xit` will cause the same
28+-- issue. `xit` tests must be the last tests in the session, or the session will
29+-- hang in the following test.
30+
2331import Prelude hiding (fail)
2432import Control.Concurrent
2533import qualified Control.Concurrent.Async as Async
@@ -137,7 +145,7 @@ deriving instance MonadFail WD
137145
138146main :: IO ()
139147main = do
140− unshareNetork
148+ unshareNetwork
141149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
142150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
143151 withSeleniumServer $ \selenium -> do
@@ -146,13 +154,13 @@ main = do
146154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
147155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
148156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
149− hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
157+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
150158
151−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
159+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
152160tests withDebugging wdConfig caps _selenium = do
153161 let putStrLnDebug :: MonadIO m => Text -> m ()
154162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
155− session' = sessionWith wdConfig "" . using (map (,"") caps)
163+ session' t = sessionWith wdConfig t . using caps
156164 runWD m = runWDOptions (WdOptions False) $ do
157165 putStrLnDebug "before"
158166 r <- m
@@ -164,7 +172,7 @@ tests withDebugging wdConfig caps _selenium = do
164172 testWidget = testWidgetDebug True withDebugging
165173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
166174 testWidget' = testWidgetDebug' True withDebugging
167− describe "text" $ session' $ do
175+ session' "text" $ do
168176 it "works" $ runWD $ do
169177 testWidgetStatic (checkBodyText "hello world") $ do
170178 text "hello world"
@@ -225,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do
225233 click <- button ""
226234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
227235
228− describe "element" $ session' $ do
236+ session' "element" $ do
229237 it "works with domEvent Click" $ runWD $ do
230238 clickedRef <- liftIO $ newRef False
231239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -289,8 +297,8 @@ tests withDebugging wdConfig caps _selenium = do
289297 let click = domEvent Click e
290298 return ()
291299
292− describe "inputElement" $ do
293− describe "static renderer" $ session' $ do
300+ session' "inputElement" $ do
301+ describe "static renderer" $ do
294302 it "sets value attribute" $ runWD $ do
295303 let checkStatic = do
296304 e <- findElemWithRetry $ WD.ByTag "input"
@@ -347,7 +355,7 @@ tests withDebugging wdConfig caps _selenium = do
347355 & inputElementConfig_initialChecked .~ False
348356 & inputElementConfig_setChecked .~ (True <$ pb)
349357 pure ()
350− describe "hydration" $ session' $ do
358+ describe "hydration" $ do
351359 it "doesn't wipe user input when switching over" $ runWD $ do
352360 inputRef <- newRef ("hello " :: Text)
353361 testWidget'
@@ -585,8 +593,7 @@ tests withDebugging wdConfig caps _selenium = do
585593 el "p" $ dynText $ _inputElement_value e
586594 performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
587595 performEvent_ $ consRef inputRef <$> _inputElement_input e
588−
589− describe "hydration/immediate" $ session' $ do
596+ describe "hydration/immediate" $ do
590597 it "captures user input after switchover" $ runWD $ do
591598 inputRef :: IORef Text <- newRef ""
592599 let checkValue = do
@@ -666,8 +673,8 @@ tests withDebugging wdConfig caps _selenium = do
666673 names <- liftJSM $ traverse File.getName fs
667674 liftIO $ writeRef filesRef names
668675
669− describe "textAreaElement" $ do
670− describe "static renderer" $ session' $ do
676+ session' "textAreaElement" $ do
677+ describe "static renderer" $ do
671678 it "sets value attribute" $ runWD $ do
672679 let checkStatic = do
673680 e <- findElemWithRetry $ WD.ByTag "textarea"
@@ -690,7 +697,7 @@ tests withDebugging wdConfig caps _selenium = do
690697 & textAreaElementConfig_initialValue .~ "test"
691698 & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
692699 pure ()
693− describe "hydration" $ session' $ do
700+ describe "hydration" $ do
694701 it "doesn't wipe user input when switching over" $ runWD $ do
695702 inputRef <- newRef ("" :: Text)
696703 testWidget'
@@ -839,7 +846,7 @@ tests withDebugging wdConfig caps _selenium = do
839846 e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
840847 el "p" $ dynText $ _textAreaElement_value e
841848
842− describe "hydration/immediate" $ session' $ do
849+ describe "hydration/immediate" $ do
843850 it "captures user input after switchover" $ runWD $ do
844851 inputRef :: IORef Text <- newRef ""
845852 let checkValue = do
@@ -881,13 +888,13 @@ tests withDebugging wdConfig caps _selenium = do
881888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
882889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
883890
884− describe "selectElement" $ do
891+ session' "selectElement" $ do
885892 let options :: DomBuilder t m => m ()
886893 options = do
887894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
888895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
889896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
890− describe "hydration" $ session' $ do
897+ describe "hydration" $ do
891898 it "sets initial value correctly" $ runWD $ do
892899 inputRef <- newRef ("" :: Text)
893900 let setup = do
@@ -961,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do
961968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
962969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
963970
964− describe "hydration/immediate" $ session' $ do
971+ describe "hydration/immediate" $ do
965972 it "captures user input after switchover" $ runWD $ do
966973 inputRef :: IORef Text <- newRef ""
967974 let checkValue = do
@@ -1007,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do
10071014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
10081015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
10091016
1010− describe "prerender" $ session' $ do
1017+ session' "prerender" $ do
10111018 it "works in simple case" $ runWD $ do
10121019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
10131020 prerender_ (text "One") (text "Two")
@@ -1076,7 +1083,7 @@ tests withDebugging wdConfig caps _selenium = do
10761083 prerender_ (pure ()) (liftIO $ trigger "Client")
10771084 textNode $ TextNodeConfig "Initial" $ Just e
10781085
1079− describe "namespaces" $ session' $ do
1086+ session' "namespaces" $ do
10801087 it "dyn can be nested in namespaced widget" $ runWD $ do
10811088 testWidget (pure ()) (checkTextInTag "svg" "one") $ do
10821089 let svgRootCfg = def
@@ -1085,7 +1092,7 @@ tests withDebugging wdConfig caps _selenium = do
10851092 void $ element "svg" svgRootCfg $ do
10861093 dyn_ $ text "one" <$ pure ()
10871094
1088− describe "runWithReplace" $ session' $ do
1095+ session' "runWithReplace" $ do
10891096 it "works" $ runWD $ do
10901097 replaceChan :: Chan Text <- liftIO newChan
10911098 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -1283,7 +1290,7 @@ tests withDebugging wdConfig caps _selenium = do
12831290 _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
12841291 text "|after"
12851292
1286− describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1293+ session' "traverseDMapWithKeyWithAdjust" $ do
12871294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
12881295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
12891296 elClass "span" "key" $ text $ textKey k
@@ -1386,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do
13861393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
13871394 liftIO $ dmap `H.shouldBe` keyMap
13881395
1389− describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1396+ session' "traverseIntMapWithKeyWithAdjust" $ do
13901397 let textKeyInt k = "key" <> T.pack (show k)
13911398 intMap = IntMap.fromList
13921399 [ (1, "one")
@@ -1493,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do
14931500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
14941501 liftIO $ dmap `H.shouldBe` intMap
14951502
1496− describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1503+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do
14971504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
14981505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
14991506 elClass "span" "key" $ text $ textKey2 k
@@ -1573,8 +1580,8 @@ tests withDebugging wdConfig caps _selenium = do
15731580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
15741581 liftIO $ assertEqual "DMap" initMap dmap
15751582
1576− describe "hydrating invalid HTML" $ session' $ do
1577− it "can hydrate list in paragraph" $ runWD $ do
1583+ session' "hydrating invalid HTML" $ do
1584+ xit "can hydrate list in paragraph" $ runWD $ do
15781585 let preSwitchover = do
15791586 checkBodyText "before\ninner\nafter"
15801587 -- Two <p> tags should be present
@@ -1603,7 +1610,7 @@ tests withDebugging wdConfig caps _selenium = do
16031610 -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
16041611 -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
16051612 -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1606− describe "dropdown" $ session' $ do
1613+ session' "dropdown" $ do
16071614 let doTest expectedOpts (initialValue :: Text) = do
16081615 let doCheck = do
16091616 es <- findElemsWithRetry $ WD.ByTag "option"
@@ -1760,7 +1767,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
17601767 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
17611768 putStrLnDebug "rendered static"
17621769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1763− onFailure <- if hardFailure then (\tid -> throwTo tid HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1770+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
17641771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
17651772 let entryPoint = do
17661773 putStrLnDebug "taking waitBeforeJS"
@@ -1772,7 +1779,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
17721779 liftIO $ putMVar waitUntilSwitchover ()
17731780 putStrLnDebug "put waitUntilSwitchover"
17741781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1775− mainHydrationWidgetWithSwitchoverAction onFailure switchOverAction blank bodyWidget
1782+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
17761783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
17771784 syncPoint
17781785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do