@@ -1,9 +1,13 @@
1+{-# OPTIONS_GHC -fno-warn-orphans #-}
1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE StandaloneDeriving #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE UndecidableInstances #-}
2{-# LANGUAGE ConstraintKinds #-}
6{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE OverloadedStrings #-}
13{-# LANGUAGE OverloadedStrings #-}
@@ -11,27 +15,13 @@
11{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15{-# LANGUAGE TemplateHaskell #-}
18{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE TupleSections #-}
17{-# LANGUAGE TypeApplications #-}
20{-# LANGUAGE TypeApplications #-}
18{-# LANGUAGE TypeFamilies #-}
21{-# LANGUAGE TypeFamilies #-}
19−{-# LANGUAGE UndecidableInstances #-}
21−{-# OPTIONS_GHC -fno-warn-orphans #-}
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.
31import Prelude hiding (fail)
23import Prelude hiding (fail)
32import Control.Concurrent
24import Control.Concurrent
33−import qualified Control.Concurrent.Async as Async
34−import Control.Lens.Operators
35import Control.Monad hiding (fail)
25import Control.Monad hiding (fail)
36import Control.Monad.Catch
26import Control.Monad.Catch
37import Control.Monad.Fail
27import Control.Monad.Fail
@@ -41,13 +31,12 @@ import Control.Monad.Ref
41import Data.Constraint.Extras
31import Data.Constraint.Extras
42import Data.Constraint.Extras.TH
32import Data.Constraint.Extras.TH
43import Data.Dependent.Map (DMap)
33import Data.Dependent.Map (DMap)
44−import Data.Dependent.Sum (DSum(..), (==>))
34+import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
45import Data.Functor.Identity
35import Data.Functor.Identity
46import Data.Functor.Misc
36import Data.Functor.Misc
47import Data.GADT.Compare.TH
37import Data.GADT.Compare.TH
48import Data.GADT.Show.TH
38import Data.GADT.Show.TH
49import Data.IORef (IORef)
39import Data.IORef (IORef)
50−import Data.List (sort)
51import Data.Maybe
40import Data.Maybe
52import Data.Proxy
41import Data.Proxy
53import Data.Text (Text)
42import Data.Text (Text)
@@ -58,7 +47,6 @@ import Network.Socket
58import Network.Wai
47import Network.Wai
59import Network.WebSockets
48import Network.WebSockets
60import Reflex.Dom.Core
49import Reflex.Dom.Core
61−import Reflex.Dom.Widget.Input (dropdown)
62import Reflex.Patch.DMapWithMove
50import Reflex.Patch.DMapWithMove
63import System.Directory
51import System.Directory
64import System.Environment
52import System.Environment
@@ -67,13 +55,14 @@ import System.IO.Silently
67import System.IO.Temp
55import System.IO.Temp
68import System.Process
56import System.Process
69import System.Which (staticWhich)
57import System.Which (staticWhich)
70−import qualified Test.HUnit as HUnit
58+import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
71import qualified Test.Hspec as H
59import qualified Test.Hspec as H
72import qualified Test.Hspec.Core.Spec as H
60import qualified Test.Hspec.Core.Spec as H
73import Test.Hspec (xit)
61import Test.Hspec (xit)
74import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
62import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
75import qualified Test.Hspec.WebDriver as WD
63import qualified Test.Hspec.WebDriver as WD
76import Test.WebDriver (WD(..))
64import Test.WebDriver (WD(..))
65+import Test.WebDriver.Exceptions (ServerError(..))
78import qualified Data.ByteString.Lazy as LBS
67import qualified Data.ByteString.Lazy as LBS
79import qualified Data.Dependent.Map as DMap
68import qualified Data.Dependent.Map as DMap
@@ -89,9 +78,6 @@ import qualified Test.WebDriver.Capabilities as WD
89import Test.Util.ChromeFlags
78import Test.Util.ChromeFlags
90import Test.Util.UnshareNetwork
79import Test.Util.UnshareNetwork
92−-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
93−deriving instance MonadMask WD
95chromium :: FilePath
81chromium :: FilePath
96chromium = $(staticWhich "chromium")
82chromium = $(staticWhich "chromium")
@@ -107,14 +93,11 @@ instance MonadRef WD where
107 writeRef r = WD . writeRef r
93 writeRef r = WD . writeRef r
109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
95assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
110−assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
96+assertEqual a b = liftIO . HUnit.assertEqual a b
112assertFailure :: MonadIO m => String -> m ()
98assertFailure :: MonadIO m => String -> m ()
113assertFailure = liftIO . HUnit.assertFailure
99assertFailure = liftIO . HUnit.assertFailure
115−assertBool :: (MonadIO m) => String -> Bool -> m ()
116−assertBool msg bool = liftIO $ HUnit.assertBool msg bool
118chromeConfig :: Text -> [Text] -> WD.WDConfig
101chromeConfig :: Text -> [Text] -> WD.WDConfig
119chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
102chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
@@ -145,7 +128,7 @@ deriving instance MonadFail WD
146main :: IO ()
129main :: IO ()
148− unshareNetwork
131+ unshareNetork
149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
132 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
133 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
151 withSeleniumServer $ \selenium -> do
134 withSeleniumServer $ \selenium -> do
@@ -154,13 +137,13 @@ main = do
154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
137 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
138 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
139 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
157− hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
140+ hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
159−tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
142+tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
160tests withDebugging wdConfig caps _selenium = do
143tests withDebugging wdConfig caps _selenium = do
161 let putStrLnDebug :: MonadIO m => Text -> m ()
144 let putStrLnDebug :: MonadIO m => Text -> m ()
162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
145 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
163− session' t = sessionWith wdConfig t . using caps
146+ session' = sessionWith wdConfig "" . using (map (,"") caps)
164 runWD m = runWDOptions (WdOptions False) $ do
147 runWD m = runWDOptions (WdOptions False) $ do
165 putStrLnDebug "before"
148 putStrLnDebug "before"
@@ -169,10 +152,10 @@ tests withDebugging wdConfig caps _selenium = do
169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
152 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
170 testWidgetStatic = testWidgetStaticDebug withDebugging
153 testWidgetStatic = testWidgetStaticDebug withDebugging
171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
154 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
172− testWidget = testWidgetDebug True withDebugging
155+ testWidget = testWidgetDebug withDebugging
173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
156 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
174− testWidget' = testWidgetDebug' True withDebugging
157+ testWidget' = testWidgetDebug' withDebugging
175− session' "text" $ do
158+ describe "text" $ session' $ do
176 it "works" $ runWD $ do
159 it "works" $ runWD $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
160 testWidgetStatic (checkBodyText "hello world") $ do
178 text "hello world"
161 text "hello world"
@@ -233,7 +216,7 @@ tests withDebugging wdConfig caps _selenium = do
233 click <- button ""
216 click <- button ""
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
217 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
236− session' "element" $ do
219+ describe "element" $ session' $ do
237 it "works with domEvent Click" $ runWD $ do
220 it "works with domEvent Click" $ runWD $ do
238 clickedRef <- liftIO $ newRef False
221 clickedRef <- liftIO $ newRef False
239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
222 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -297,78 +280,21 @@ tests withDebugging wdConfig caps _selenium = do
297 let click = domEvent Click e
280 let click = domEvent Click e
298 return ()
281 return ()
300− session' "inputElement" $ do
283+ describe "inputElement" $ do
301− describe "static renderer" $ do
284+ describe "hydration" $ session' $ do
302− it "sets value attribute" $ runWD $ do
303− let checkStatic = do
304− e <- findElemWithRetry $ WD.ByTag "input"
305− WD.attr e "value" `shouldBeWithRetryM` Just "test"
307− checkHydrated e = do
308− WD.attr e "value" `shouldBeWithRetryM` Just "test"
309− testWidget' checkStatic checkHydrated $ void $ inputElement $ def
310− & inputElementConfig_initialValue .~ "test"
311− it "updates value attribute at postBuild" $ runWD $ do
312− let checkStatic = do
313− e <- findElemWithRetry $ WD.ByTag "input"
314− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
316− checkHydrated e = do
317− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
318− testWidget' checkStatic checkHydrated $ do
320− _ <- inputElement $ def
321− & inputElementConfig_initialValue .~ "test"
322− & inputElementConfig_setValue .~ ("test-updated" <$ pb)
324− it "sets checked attr appropriately" $ runWD $ do
325− setCheckedChan <- liftIO newChan
326− let checkStatic = do
327− e <- findElemWithRetry $ WD.ByTag "input"
328− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
331− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
333− WD.click e -- Click to uncheck
334− WD.attr e "checked" `shouldBeWithRetryM` Nothing
335− liftIO $ writeChan setCheckedChan True -- Programatically check the checkbox
336− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
337− testWidget' checkStatic checkValue $ do
338− setChecked <- triggerEventWithChan setCheckedChan
339− _ <- inputElement $ def
340− & initialAttributes .~ "type" =: "checkbox"
341− & inputElementConfig_initialChecked .~ True
342− & inputElementConfig_setChecked .~ setChecked
344− it "sets checked attr appropriately at postbuild" $ runWD $ do
345− let checkStatic = do
346− e <- findElemWithRetry $ WD.ByTag "input"
347− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
350− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
351− testWidget' checkStatic checkValue $ do
353− _ <- inputElement $ def
354− & initialAttributes .~ "type" =: "checkbox"
355− & inputElementConfig_initialChecked .~ False
356− & inputElementConfig_setChecked .~ (True <$ pb)
358− describe "hydration" $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
285 it "doesn't wipe user input when switching over" $ runWD $ do
360− inputRef <- newRef ("hello " :: Text)
286+ inputRef <- newRef ("" :: Text)
361 testWidget'
287 testWidget'
363 e <- findElemWithRetry $ WD.ByTag "input"
289 e <- findElemWithRetry $ WD.ByTag "input"
364− WD.sendKeys "world" e
290+ WD.sendKeys "hello world" e
366 (\e -> do
292 (\e -> do
367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
293 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
368 WD.click =<< findElemWithRetry (WD.ByTag "button")
294 WD.click =<< findElemWithRetry (WD.ByTag "button")
369 readRef inputRef `shouldBeWithRetryM` "hello world"
295 readRef inputRef `shouldBeWithRetryM` "hello world"
371− e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
297+ e <- inputElement def
372 click <- button "save"
298 click <- button "save"
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
299 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
374 it "captures user input after switchover" $ runWD $ do
300 it "captures user input after switchover" $ runWD $ do
@@ -425,49 +351,24 @@ tests withDebugging wdConfig caps _selenium = do
425 checkedByUIRef <- newRef False
351 checkedByUIRef <- newRef False
426 checkedRef <- newRef False
352 checkedRef <- newRef False
427 setCheckedChan <- liftIO newChan
353 setCheckedChan <- liftIO newChan
428− let checkStatic = do
429− e <- findElemWithRetry $ WD.ByTag "input"
430− WD.attr e "checked" `shouldBeWithRetryM` Nothing
432− checkValue e = do
354+ let checkValue = do
433 readRef checkedByUIRef `shouldBeWithRetryM` False
355 readRef checkedByUIRef `shouldBeWithRetryM` False
434 readRef checkedRef `shouldBeWithRetryM` False
356 readRef checkedRef `shouldBeWithRetryM` False
435− WD.attr e "checked" `shouldBeWithRetryM` Nothing
357+ e <- findElemWithRetry $ WD.ByTag "input"
436 WD.moveToCenter e
358 WD.moveToCenter e
437 WD.click e
359 WD.click e
438 readRef checkedByUIRef `shouldBeWithRetryM` True
360 readRef checkedByUIRef `shouldBeWithRetryM` True
439 readRef checkedRef `shouldBeWithRetryM` True
361 readRef checkedRef `shouldBeWithRetryM` True
440− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
441 liftIO $ writeChan setCheckedChan False
362 liftIO $ writeChan setCheckedChan False
442 readRef checkedByUIRef `shouldBeWithRetryM` True
363 readRef checkedByUIRef `shouldBeWithRetryM` True
443 readRef checkedRef `shouldBeWithRetryM` False
364 readRef checkedRef `shouldBeWithRetryM` False
444− WD.attr e "checked" `shouldBeWithRetryM` Nothing
445− testWidget' checkStatic checkValue $ do
365+ testWidget (pure ()) checkValue $ do
446 setChecked <- triggerEventWithChan setCheckedChan
366 setChecked <- triggerEventWithChan setCheckedChan
447 e <- inputElement $ def
367 e <- inputElement $ def
448 & initialAttributes .~ "type" =: "checkbox"
368 & initialAttributes .~ "type" =: "checkbox"
449 & inputElementConfig_setChecked .~ setChecked
369 & inputElementConfig_setChecked .~ setChecked
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
370 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
451 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
371 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
452− it "respects user updates to checked which happen before hydration" $ runWD $ do
453− checkedByUIRef <- newRef False
454− checkedRef <- newRef False
455− let checkStatic = do
456− e <- findElemWithRetry $ WD.ByTag "input"
457− WD.attr e "checked" `shouldBeWithRetryM` Nothing
460− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
463− WD.attr e "checked" `shouldBeWithRetryM` Just "true"
464− readRef checkedByUIRef `shouldBeWithRetryM` True
465− readRef checkedRef `shouldBeWithRetryM` True
466− testWidget' checkStatic checkValue $ do
467− e <- inputElement $ def
468− & initialAttributes .~ "type" =: "checkbox"
469− performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
470− performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
471 it "captures file uploads" $ runWD $ do
372 it "captures file uploads" $ runWD $ do
472 filesRef :: IORef [Text] <- newRef []
373 filesRef :: IORef [Text] <- newRef []
473 let uploadFile = do
374 let uploadFile = do
@@ -483,117 +384,8 @@ tests withDebugging wdConfig caps _selenium = do
483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
384 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
484 names <- liftJSM $ traverse File.getName fs
385 names <- liftJSM $ traverse File.getName fs
485 liftIO $ writeRef filesRef names
386 liftIO $ writeRef filesRef names
486− it "fires _input event if the user altered the value before hydration" $ runWD $ do
387+
487− input <- newRef ("" :: Text)
488− update <- newRef ("" :: Text)
489− let checkStatic = do
490− e <- findElemWithRetry $ WD.ByTag "input"
491− WD.attr e "value" `shouldBeWithRetryM` Just ""
492− WD.sendKeys "test" e
493− WD.attr e "value" `shouldBeWithRetryM` Just "test"
495− checkHydrated e = do
496− WD.attr e "value" `shouldBeWithRetryM` Just "test"
497− readRef input `shouldBeWithRetryM` "test"
498− readRef update `shouldBeWithRetryM` "test"
499− testWidget' checkStatic checkHydrated $ do
500− e <- inputElement def
501− performEvent_ $ liftIO . writeRef input <$> _inputElement_input e
502− performEvent_ $ liftIO . writeRef update <$> updated (_inputElement_value e)
503− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
504− input <- newRef (Nothing :: Maybe Text)
505− let checkStatic = do
506− e <- findElemWithRetry $ WD.ByTag "input"
507− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
509− checkHydrated e = do
510− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
511− readRef input `shouldBeWithRetryM` Nothing
512− testWidget' checkStatic checkHydrated $ do
514− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
515− performEvent_ $ liftIO . writeRef input . Just <$> _inputElement_input e
516− it "SSR produces correct DOM based on inputElement values when setValue happens at postBuild" $ runWD $ do
518− input <- findElemWithRetry $ WD.ByTag "input"
519− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
520− p <- findElemWithRetry (WD.ByTag "p")
521− shouldContainText "pb" p
522− testWidget checkBoth checkBoth $ do
524− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
525− el "p" $ dynText $ _inputElement_value e
526− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
527− let checkStatic = do
528− input <- findElemWithRetry $ WD.ByTag "input"
529− h2_value <- findElemWithRetry (WD.ByTag "h2")
530− h3_input <- findElemWithRetry (WD.ByTag "h3")
531− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
532− shouldContainText "pb" h2_value
533− shouldContainText "" h3_input
534− WD.sendKeys "abc" input
535− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
536− shouldContainText "pb" h2_value
537− shouldContainText "" h3_input
538− pure (input, h2_value, h3_input)
539− checkHydrated (input, h2_value, h3_input) = do
540− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
541− shouldContainText "pbabc" h3_input
542− shouldContainText "pbabc pb" h2_value
544− testWidget' checkStatic checkHydrated $ do
546− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
547− el "h1" $ dynText $ _inputElement_value e
548− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _inputElement_value e
549− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _inputElement_input e
550− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
551− let checkStatic = do
552− input <- findElemWithRetry $ WD.ByTag "input"
553− p <- findElemWithRetry (WD.ByTag "p")
554− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
555− shouldContainText "pb" p
556− WD.sendKeys "abc" input
557− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
558− shouldContainText "pb" p -- It won't be updated yet
560− checkHydrated (input, p) = do
561− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
562− shouldContainText "pbabc" p
564− testWidget' checkStatic checkHydrated $ do
566− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
567− el "p" $ dynText $ _inputElement_value e
568− it "input event and (updated value) fire correctly when both setValue AND user updated value happen before switchover" $ runWD $ do
569− valRef <- newRef ([] :: [Text])
570− inputRef <- newRef ([] :: [Text])
571− let consRef ref a = liftIO $ atomicModifyRef ref $ \as -> (a:as, ())
573− input <- findElemWithRetry $ WD.ByTag "input"
574− p <- findElemWithRetry (WD.ByTag "p")
575− WD.attr input "value" `shouldBeWithRetryM` Just "pb"
576− shouldContainText "pb" p
577− WD.sendKeys "abc" input
578− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
579− shouldContainText "pb" p -- It won't be updated yet
580− readRef inputRef `shouldBeWithRetryM` [] -- Should never fire input ref during SSR
581− readRef valRef `shouldBeWithRetryM` ["pb"]
583− checkHydrated (input, p) = do
584− readRef inputRef `shouldBeWithRetryM` ["pbabc"]
585− readRef valRef `shouldBeWithRetryM` ["pbabc", "pb"]
586− WD.attr input "value" `shouldBeWithRetryM` Just "pbabc"
587− shouldContainText "pbabc" p
589− testWidget' checkStatic checkHydrated $ do
590− liftIO $ writeRef valRef []
592− e <- inputElement $ def & inputElementConfig_setValue .~ ("pb" <$ pb)
593− el "p" $ dynText $ _inputElement_value e
594− performEvent_ $ consRef valRef <$> updated (_inputElement_value e)
595− performEvent_ $ consRef inputRef <$> _inputElement_input e
596− describe "hydration/immediate" $ do
388+ describe "hydration/immediate" $ session' $ do
597 it "captures user input after switchover" $ runWD $ do
389 it "captures user input after switchover" $ runWD $ do
598 inputRef :: IORef Text <- newRef ""
390 inputRef :: IORef Text <- newRef ""
599 let checkValue = do
391 let checkValue = do
@@ -673,31 +465,8 @@ tests withDebugging wdConfig caps _selenium = do
673 names <- liftJSM $ traverse File.getName fs
465 names <- liftJSM $ traverse File.getName fs
674 liftIO $ writeRef filesRef names
466 liftIO $ writeRef filesRef names
676− session' "textAreaElement" $ do
468+ describe "textAreaElement" $ do
677− describe "static renderer" $ do
678− it "sets value attribute" $ runWD $ do
679− let checkStatic = do
680− e <- findElemWithRetry $ WD.ByTag "textarea"
681− WD.attr e "value" `shouldBeWithRetryM` Just "test"
683− checkHydrated e = do
684− WD.attr e "value" `shouldBeWithRetryM` Just "test"
685− testWidget' checkStatic checkHydrated $ void $ textAreaElement $ def
686− & textAreaElementConfig_initialValue .~ "test"
687− it "updates value attribute at postBuild" $ runWD $ do
688− let checkStatic = do
689− e <- findElemWithRetry $ WD.ByTag "textarea"
690− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
692− checkHydrated e = do
693− WD.attr e "value" `shouldBeWithRetryM` Just "test-updated"
694− testWidget' checkStatic checkHydrated $ do
696− _ <- textAreaElement $ def
697− & textAreaElementConfig_initialValue .~ "test"
698− & textAreaElementConfig_setValue .~ ("test-updated" <$ pb)
700− describe "hydration" $ do
469+ describe "hydration" $ session' $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
470 it "doesn't wipe user input when switching over" $ runWD $ do
702 inputRef <- newRef ("" :: Text)
471 inputRef <- newRef ("" :: Text)
703 testWidget'
472 testWidget'
@@ -763,90 +532,8 @@ tests withDebugging wdConfig caps _selenium = do
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
532 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
533 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
765 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
534 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
766− it "fires _input event if the user altered the value before hydration" $ runWD $ do
767− textarea <- newRef ("" :: Text)
768− update <- newRef ("" :: Text)
769− let checkStatic = do
770− e <- findElemWithRetry $ WD.ByTag "textarea"
771− WD.attr e "value" `shouldBeWithRetryM` Just ""
772− WD.sendKeys "test" e
773− WD.attr e "value" `shouldBeWithRetryM` Just "test"
775− checkHydrated e = do
776− WD.attr e "value" `shouldBeWithRetryM` Just "test"
777− readRef textarea `shouldBeWithRetryM` "test"
778− readRef update `shouldBeWithRetryM` "test"
779− testWidget' checkStatic checkHydrated $ do
780− e <- textAreaElement def
781− performEvent_ $ liftIO . writeRef textarea <$> _textAreaElement_input e
782− performEvent_ $ liftIO . writeRef update <$> updated (_textAreaElement_value e)
783− it "does not fire _input event when the value is updated at postBuild" $ runWD $ do
784− textarea <- newRef (Nothing :: Maybe Text)
785− let checkStatic = do
786− e <- findElemWithRetry $ WD.ByTag "textarea"
787− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
789− checkHydrated e = do
790− WD.attr e "value" `shouldBeWithRetryM` Just "pb"
791− readRef textarea `shouldBeWithRetryM` Nothing
792− testWidget' checkStatic checkHydrated $ do
794− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
795− performEvent_ $ liftIO . writeRef textarea . Just <$> _textAreaElement_input e
796− it "SSR produces correct DOM based on textAreaElement values when setValue happens at postBuild" $ runWD $ do
798− textarea <- findElemWithRetry $ WD.ByTag "textarea"
799− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
800− p <- findElemWithRetry (WD.ByTag "p")
801− shouldContainText "pb" p
802− testWidget checkBoth checkBoth $ do
804− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
805− el "p" $ dynText $ _textAreaElement_value e
806− it "does not fail when both setValue AND user updated value happen before switchover" $ runWD $ do
807− let checkStatic = do
808− textarea <- findElemWithRetry $ WD.ByTag "textarea"
809− h2_value <- findElemWithRetry (WD.ByTag "h2")
810− h3_input <- findElemWithRetry (WD.ByTag "h3")
811− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
812− shouldContainText "pb" h2_value
813− shouldContainText "" h3_input
814− WD.sendKeys "abc" textarea
815− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
816− shouldContainText "pb" h2_value
817− shouldContainText "" h3_input
818− pure (textarea, h2_value, h3_input)
819− checkHydrated (textarea, h2_value, h3_input) = do
820− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
821− shouldContainText "pbabc" h3_input
822− shouldContainText "pbabc pb" h2_value
824− testWidget' checkStatic checkHydrated $ do
826− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
827− el "h1" $ dynText $ _textAreaElement_value e
828− el "h2" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ updated $ _textAreaElement_value e
829− el "h3" $ dynText . fmap T.unwords <=< foldDyn (:) [] $ _textAreaElement_input e
830− it "value is correct when both setValue AND user updated value happen before switchover" $ runWD $ do
831− let checkStatic = do
832− textarea <- findElemWithRetry $ WD.ByTag "textarea"
833− p <- findElemWithRetry (WD.ByTag "p")
834− WD.attr textarea "value" `shouldBeWithRetryM` Just "pb"
835− shouldContainText "pb" p
836− WD.sendKeys "abc" textarea
837− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
838− shouldContainText "pb" p -- It won't be updated yet
840− checkHydrated (textarea, p) = do
841− WD.attr textarea "value" `shouldBeWithRetryM` Just "pbabc"
842− shouldContainText "pbabc" p
844− testWidget' checkStatic checkHydrated $ do
846− e <- textAreaElement $ def & textAreaElementConfig_setValue .~ ("pb" <$ pb)
847− el "p" $ dynText $ _textAreaElement_value e
849− describe "hydration/immediate" $ do
536+ describe "hydration/immediate" $ session' $ do
850 it "captures user input after switchover" $ runWD $ do
537 it "captures user input after switchover" $ runWD $ do
851 inputRef :: IORef Text <- newRef ""
538 inputRef :: IORef Text <- newRef ""
852 let checkValue = do
539 let checkValue = do
@@ -888,13 +575,13 @@ tests withDebugging wdConfig caps _selenium = do
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
575 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
576 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
891− session' "selectElement" $ do
578+ describe "selectElement" $ do
892 let options :: DomBuilder t m => m ()
579 let options :: DomBuilder t m => m ()
893 options = do
580 options = do
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
581 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
582 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
583 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
897− describe "hydration" $ do
584+ describe "hydration" $ session' $ do
898 it "sets initial value correctly" $ runWD $ do
585 it "sets initial value correctly" $ runWD $ do
899 inputRef <- newRef ("" :: Text)
586 inputRef <- newRef ("" :: Text)
900 let setup = do
587 let setup = do
@@ -968,7 +655,7 @@ tests withDebugging wdConfig caps _selenium = do
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
655 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
656 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
971− describe "hydration/immediate" $ do
658+ describe "hydration/immediate" $ session' $ do
972 it "captures user input after switchover" $ runWD $ do
659 it "captures user input after switchover" $ runWD $ do
973 inputRef :: IORef Text <- newRef ""
660 inputRef :: IORef Text <- newRef ""
974 let checkValue = do
661 let checkValue = do
@@ -1014,7 +701,7 @@ tests withDebugging wdConfig caps _selenium = do
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
701 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
702 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1017− session' "prerender" $ do
704+ describe "prerender" $ session' $ do
1018 it "works in simple case" $ runWD $ do
705 it "works in simple case" $ runWD $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
706 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1020 prerender_ (text "One") (text "Two")
707 prerender_ (text "One") (text "Two")
@@ -1083,16 +770,7 @@ tests withDebugging wdConfig caps _selenium = do
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
770 prerender_ (pure ()) (liftIO $ trigger "Client")
1084 textNode $ TextNodeConfig "Initial" $ Just e
771 textNode $ TextNodeConfig "Initial" $ Just e
1086− session' "namespaces" $ do
1087− it "dyn can be nested in namespaced widget" $ runWD $ do
1088− testWidget (pure ()) (checkTextInTag "svg" "one") $ do
1089− let svgRootCfg = def
1090− & (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
1091− & (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
1092− void $ element "svg" svgRootCfg $ do
1093− dyn_ $ text "one" <$ pure ()
1095− session' "runWithReplace" $ do
773+ describe "runWithReplace" $ session' $ do
1096 it "works" $ runWD $ do
774 it "works" $ runWD $ do
1097 replaceChan :: Chan Text <- liftIO newChan
775 replaceChan :: Chan Text <- liftIO newChan
1098 let setup = findElemWithRetry $ WD.ByTag "div"
776 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -1236,61 +914,7 @@ tests withDebugging wdConfig caps _selenium = do
1236 , el "span" . text <$> replace
914 , el "span" . text <$> replace
1239− let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
1240− it "removes bracketing comments" $ runWD $ do
1241− replaceChan :: Chan () <- liftIO newChan
1243− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1245− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1246− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1247− checkInnerHtml "div" "before|<p>inner2</p>|after"
1248− testWidget' preSwitchover check $ do
1249− replace <- triggerEventWithChan replaceChan
1252− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1254− it "ignores extra ending bracketing comment" $ runWD $ do
1255− replaceChan :: Chan () <- liftIO newChan
1257− preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
1259− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1260− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1261− checkInnerHtml "div" "before|inner2|after"
1262− testWidget' preSwitchover check $ do
1263− replace <- triggerEventWithChan replaceChan
1266− _ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
1268− void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
1269− -- TODO This test actually causes a hydration failure, but it wasn't
1270− -- previously detected, so I've marked it pending
1271− xit "ignores missing ending bracketing comments" $ runWD $ do
1272− replaceChan :: Chan () <- liftIO newChan
1275− checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
1276− divEl <- findElemWithRetry (WD.ByTag "div")
1277− let wrongHtml = "<!--replace-start-0-->inner1"
1278− actualHtml :: String <- WD.executeJS
1279− [WD.JSArg divEl, WD.JSArg wrongHtml]
1280− "arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
1281− actualHtml `shouldBe` wrongHtml
1283− liftIO $ writeChan replaceChan () -- trigger creation of p tag
1284− _ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
1285− checkInnerHtml "div" "before|<p>inner2</p>|after"
1286− testWidget' preSwitchover check $ do
1287− replace <- triggerEventWithChan replaceChan
1290− _ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
1293− session' "traverseDMapWithKeyWithAdjust" $ do
917+ describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
918 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
919 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1296 elClass "span" "key" $ text $ textKey k
920 elClass "span" "key" $ text $ textKey k
@@ -1393,7 +1017,7 @@ tests withDebugging wdConfig caps _selenium = do
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1017 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1394 liftIO $ dmap `H.shouldBe` keyMap
1018 liftIO $ dmap `H.shouldBe` keyMap
1396− session' "traverseIntMapWithKeyWithAdjust" $ do
1020+ describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1397 let textKeyInt k = "key" <> T.pack (show k)
1021 let textKeyInt k = "key" <> T.pack (show k)
1398 intMap = IntMap.fromList
1022 intMap = IntMap.fromList
1399 [ (1, "one")
1023 [ (1, "one")
@@ -1500,7 +1124,7 @@ tests withDebugging wdConfig caps _selenium = do
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1124 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1501 liftIO $ dmap `H.shouldBe` intMap
1125 liftIO $ dmap `H.shouldBe` intMap
1503− session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1127+ describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1128 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1129 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1506 elClass "span" "key" $ text $ textKey2 k
1130 elClass "span" "key" $ text $ textKey2 k
@@ -1580,8 +1204,8 @@ tests withDebugging wdConfig caps _selenium = do
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1204 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1581 liftIO $ assertEqual "DMap" initMap dmap
1205 liftIO $ assertEqual "DMap" initMap dmap
1583− session' "hydrating invalid HTML" $ do
1207+ describe "hydrating invalid HTML" $ session' $ do
1584− xit "can hydrate list in paragraph" $ runWD $ do
1208+ it "can hydrate list in paragraph" $ runWD $ do
1585 let preSwitchover = do
1209 let preSwitchover = do
1586 checkBodyText "before\ninner\nafter"
1210 checkBodyText "before\ninner\nafter"
1587 -- Two <p> tags should be present
1211 -- Two <p> tags should be present
@@ -1598,8 +1222,7 @@ tests withDebugging wdConfig caps _selenium = do
1598 shouldContainText "before\ninner\nafter" p1
1222 shouldContainText "before\ninner\nafter" p1
1599 elementShouldBeRemoved ol
1223 elementShouldBeRemoved ol
1600 elementShouldBeRemoved p2
1224 elementShouldBeRemoved p2
1601− -- Don't fail fatally when hydration encounters the invalid DOM
1602− testWidgetDebug' False withDebugging preSwitchover check $ do
1225+ testWidget' preSwitchover check $ do
1603 -- This is deliberately invalid HTML, the browser will interpret it as
1226 -- This is deliberately invalid HTML, the browser will interpret it as
1604 -- <p>before</p><ol>inner</ol>after<p></p>
1227 -- <p>before</p><ol>inner</ol>after<p></p>
1605 el "p" $ do
1228 el "p" $ do
@@ -1607,29 +1230,6 @@ tests withDebugging wdConfig caps _selenium = do
1607 el "ol" $ text "inner"
1230 el "ol" $ text "inner"
1608 text "after"
1231 text "after"
1610− -- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
1611− -- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
1612− -- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
1613− session' "dropdown" $ do
1614− let doTest expectedOpts (initialValue :: Text) = do
1616− es <- findElemsWithRetry $ WD.ByTag "option"
1617− opts <- mapM fetchElement es
1618− assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
1619− testWidget doCheck doCheck $ do
1620− void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
1621− fetchElement e = do
1622− val <- WD.attr e "value"
1623− sel <- WD.attr e "selected"
1624− return (fromMaybe "" val, isJust sel)
1625− -- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)
1626− -- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
1627− xit "statically renders initial values (on aa)" $ runWD $ do
1628− doTest [("0",True),("1",False)] "aa"
1629− -- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well
1630− xit "statically renders initial values (on bb)" $ runWD $ do
1631− doTest [("0",False),("1",True)] "bb"
1633data Selenium = Selenium
1233data Selenium = Selenium
1634 { _selenium_portNumber :: PortNumber
1234 { _selenium_portNumber :: PortNumber
1635 , _selenium_stopServer :: IO ()
1235 , _selenium_stopServer :: IO ()
@@ -1697,9 +1297,6 @@ checkTextInId i expected = do
1697findElemWithRetry :: Selector -> WD WD.Element
1297findElemWithRetry :: Selector -> WD WD.Element
1698findElemWithRetry = withRetry . WD.findElem
1298findElemWithRetry = withRetry . WD.findElem
1700−findElemsWithRetry :: Selector -> WD [WD.Element]
1701−findElemsWithRetry = withRetry . WD.findElems
1703getBody :: WD WD.Element
1300getBody :: WD WD.Element
1704getBody = WD.findElem $ WD.ByTag "body"
1301getBody = WD.findElem $ WD.ByTag "body"
@@ -1708,8 +1305,8 @@ withRetry a = wait 300
1708 where wait :: Int -> WD a
1305 where wait :: Int -> WD a
1709 wait 0 = a
1306 wait 0 = a
1710 wait n = try a >>= \case
1307 wait n = try a >>= \case
1711− Left (e :: SomeException) -> do
1308+ Left (_ :: SomeException) -> do
1712− liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1309+ liftIO $ threadDelay 100000
1713 wait $ n - 1
1310 wait $ n - 1
1714 Right v -> return v
1311 Right v -> return v
@@ -1725,12 +1322,11 @@ testWidgetStaticDebug
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1322 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1726 -- ^ Widget we are testing
1323 -- ^ Widget we are testing
1728−testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1325+testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1730-- | TODO: do something about JSExceptions not causing tests to fail
1327-- | TODO: do something about JSExceptions not causing tests to fail
1731testWidgetDebug
1328testWidgetDebug
1734 -> WD ()
1330 -> WD ()
1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1331 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
@@ -1738,16 +1334,12 @@ testWidgetDebug
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1334 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1739 -- ^ Widget we are testing
1335 -- ^ Widget we are testing
1741−testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1337+testWidgetDebug withDebugging beforeJS afterSwitchover =
1742− testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1338+ testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1744−data HydrationFailedException = HydrationFailedException deriving Show
1745−instance Exception HydrationFailedException
1747-- | TODO: do something about JSExceptions not causing tests to fail
1340-- | TODO: do something about JSExceptions not causing tests to fail
1748testWidgetDebug'
1341testWidgetDebug'
1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1344 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1753 -> (a -> WD b)
1345 -> (a -> WD b)
@@ -1755,7 +1347,7 @@ testWidgetDebug'
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1347 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1756 -- ^ Widget we are testing (contents of body)
1348 -- ^ Widget we are testing (contents of body)
1758−testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1350+testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1759 let putStrLnDebug :: MonadIO m => Text -> m ()
1351 let putStrLnDebug :: MonadIO m => Text -> m ()
1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1352 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1761 staticApp = do
1353 staticApp = do
@@ -1767,7 +1359,6 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1767 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1359 ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1768 putStrLnDebug "rendered static"
1360 putStrLnDebug "rendered static"
1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1361 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770− onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1362 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1772 let entryPoint = do
1363 let entryPoint = do
1773 putStrLnDebug "taking waitBeforeJS"
1364 putStrLnDebug "taking waitBeforeJS"
@@ -1779,7 +1370,7 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1779 liftIO $ putMVar waitUntilSwitchover ()
1370 liftIO $ putMVar waitUntilSwitchover ()
1780 putStrLnDebug "put waitUntilSwitchover"
1371 putStrLnDebug "put waitUntilSwitchover"
1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1372 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1782− mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1373+ mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1374 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1784 syncPoint
1375 syncPoint
1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1376 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1797,26 +1388,23 @@ testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget =
1798 -- hSilence to get rid of ConnectionClosed logs
1389 -- hSilence to get rid of ConnectionClosed logs
1799 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1390 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1800− jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1391+ jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1801− withAsync' jsaddleWarp $ do
1392+ jsaddleTid <- liftIO jsaddleWarp
1802− putStrLnDebug "taking waitJSaddle"
1393+ putStrLnDebug "taking waitJSaddle"
1803− liftIO $ takeMVar waitJSaddle
1394+ liftIO $ takeMVar waitJSaddle
1804− putStrLnDebug "opening page"
1395+ putStrLnDebug "opening page"
1805− WD.openPage $ "http://localhost:" <> show jsaddlePort
1396+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1806− putStrLnDebug "running beforeJS"
1397+ putStrLnDebug "running beforeJS"
1807− a <- beforeJS
1398+ a <- beforeJS
1808− putStrLnDebug "putting waitBeforeJS"
1399+ putStrLnDebug "putting waitBeforeJS"
1809− liftIO $ putMVar waitBeforeJS ()
1400+ liftIO $ putMVar waitBeforeJS ()
1810− putStrLnDebug "taking waitUntilSwitchover"
1401+ putStrLnDebug "taking waitUntilSwitchover"
1811− liftIO $ takeMVar waitUntilSwitchover
1402+ liftIO $ takeMVar waitUntilSwitchover
1812− putStrLnDebug "running afterSwitchover"
1403+ putStrLnDebug "running afterSwitchover"
1813− afterSwitchover a
1404+ b <- afterSwitchover a
1814−
1405+ putStrLnDebug "killing jsaddle thread"
1815−withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1406+ liftIO $ killThread jsaddleTid
1816−withAsync' f g = bracket
1407+ return b
1817− (liftIO $ Async.async f)
1818− (liftIO . Async.uninterruptibleCancel)
1821data Key2 a where
1409data Key2 a where
1822 Key2_Int :: Int -> Key2 Int
1410 Key2_Int :: Int -> Key2 Int