@@ -1,13 +1,9 @@
1−{-# OPTIONS_GHC -fno-warn-orphans #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE UndecidableInstances #-}
6{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
8{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
9{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
13{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
@@ -15,13 +11,27 @@
15{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE RecursiveDo #-}
12{-# LANGUAGE RecursiveDo #-}
17{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE TemplateHaskell #-}
15{-# LANGUAGE TemplateHaskell #-}
19{-# LANGUAGE TupleSections #-}
16{-# LANGUAGE TupleSections #-}
20{-# LANGUAGE TypeApplications #-}
17{-# LANGUAGE TypeApplications #-}
21{-# LANGUAGE TypeFamilies #-}
18{-# 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.
23import Prelude hiding (fail)
31import Prelude hiding (fail)
24import Control.Concurrent
32import Control.Concurrent
33+import qualified Control.Concurrent.Async as Async
34+import Control.Lens.Operators
25import Control.Monad hiding (fail)
35import Control.Monad hiding (fail)
26import Control.Monad.Catch
36import Control.Monad.Catch
27import Control.Monad.Fail
37import Control.Monad.Fail
@@ -31,12 +41,13 @@ import Control.Monad.Ref
31import Data.Constraint.Extras
41import Data.Constraint.Extras
32import Data.Constraint.Extras.TH
42import Data.Constraint.Extras.TH
33import Data.Dependent.Map (DMap)
43import Data.Dependent.Map (DMap)
34−import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
44+import Data.Dependent.Sum (DSum(..), (==>))
35import Data.Functor.Identity
45import Data.Functor.Identity
36import Data.Functor.Misc
46import Data.Functor.Misc
37import Data.GADT.Compare.TH
47import Data.GADT.Compare.TH
38import Data.GADT.Show.TH
48import Data.GADT.Show.TH
39import Data.IORef (IORef)
49import Data.IORef (IORef)
50+import Data.List (sort)
40import Data.Maybe
51import Data.Maybe
41import Data.Proxy
52import Data.Proxy
42import Data.Text (Text)
53import Data.Text (Text)
@@ -47,6 +58,7 @@ import Network.Socket
47import Network.Wai
58import Network.Wai
48import Network.WebSockets
59import Network.WebSockets
49import Reflex.Dom.Core
60import Reflex.Dom.Core
61+import Reflex.Dom.Widget.Input (dropdown)
50import Reflex.Patch.DMapWithMove
62import Reflex.Patch.DMapWithMove
51import System.Directory
63import System.Directory
52import System.Environment
64import System.Environment
@@ -54,14 +66,14 @@ import System.IO (stderr)
54import System.IO.Silently
66import System.IO.Silently
55import System.IO.Temp
67import System.IO.Temp
56import System.Process
68import System.Process
69+import System.Which (staticWhich)
57−import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
70+import qualified Test.HUnit as HUnit
58import qualified Test.Hspec as H
71import qualified Test.Hspec as H
59import qualified Test.Hspec.Core.Spec as H
72import qualified Test.Hspec.Core.Spec as H
60import Test.Hspec (xit)
73import Test.Hspec (xit)
61import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
74import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
62import qualified Test.Hspec.WebDriver as WD
75import qualified Test.Hspec.WebDriver as WD
63import Test.WebDriver (WD(..))
76import Test.WebDriver (WD(..))
64−import Test.WebDriver.Exceptions (ServerError(..))
66import qualified Data.ByteString.Lazy as LBS
78import qualified Data.ByteString.Lazy as LBS
67import qualified Data.Dependent.Map as DMap
79import qualified Data.Dependent.Map as DMap
@@ -77,6 +89,12 @@ import qualified Test.WebDriver.Capabilities as WD
77import Test.Util.ChromeFlags
89import Test.Util.ChromeFlags
78import Test.Util.UnshareNetwork
90import Test.Util.UnshareNetwork
92+-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
93+deriving instance MonadMask WD
96+chromium = $(staticWhich "chromium")
80seleniumPort, jsaddlePort :: PortNumber
98seleniumPort, jsaddlePort :: PortNumber
81seleniumPort = 8000
99seleniumPort = 8000
82jsaddlePort = 8001
100jsaddlePort = 8001
@@ -89,11 +107,14 @@ instance MonadRef WD where
89 writeRef r = WD . writeRef r
107 writeRef r = WD . writeRef r
91assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
109assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
92−assertEqual a b = liftIO . HUnit.assertEqual a b
110+assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
94assertFailure :: MonadIO m => String -> m ()
112assertFailure :: MonadIO m => String -> m ()
95assertFailure = liftIO . HUnit.assertFailure
113assertFailure = liftIO . HUnit.assertFailure
115+assertBool :: (MonadIO m) => String -> Bool -> m ()
116+assertBool msg bool = liftIO $ HUnit.assertBool msg bool
97chromeConfig :: Text -> [Text] -> WD.WDConfig
118chromeConfig :: Text -> [Text] -> WD.WDConfig
98chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
119chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
@@ -124,22 +145,22 @@ deriving instance MonadFail WD
125main :: IO ()
146main :: IO ()
127− unshareNetork
148+ unshareNetwork
128 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
149 isHeadless <- (== Nothing) <$> lookupEnv "NO_HEADLESS"
129 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
150 withSandboxedChromeFlags isHeadless $ \chromeFlags -> do
130 withSeleniumServer $ \selenium -> do
151 withSeleniumServer $ \selenium -> do
131− browserPath <- liftIO $ T.strip . T.pack <$> readProcess "which" [ "chromium" ] ""
152+ let browserPath = T.strip $ T.pack chromium
132 when (T.null browserPath) $ fail "No browser found"
153 when (T.null browserPath) $ fail "No browser found"
133 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
154 withDebugging <- isNothing <$> lookupEnv "NO_DEBUG"
134 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
155 let wdConfig = WD.defaultConfig { WD.wdPort = fromIntegral $ _selenium_portNumber selenium }
135 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
156 chromeCaps' = WD.getCaps $ chromeConfig browserPath chromeFlags
136− hspec (tests withDebugging wdConfig [chromeCaps'] selenium) `finally` _selenium_stopServer selenium
157+ hspec (tests withDebugging wdConfig [(chromeCaps', "chrome")] selenium) `finally` _selenium_stopServer selenium
138−tests :: Bool -> WD.WDConfig -> [Capabilities] -> Selenium -> Spec
159+tests :: Bool -> WD.WDConfig -> [(Capabilities, String)] -> Selenium -> Spec
139tests withDebugging wdConfig caps _selenium = do
160tests withDebugging wdConfig caps _selenium = do
140 let putStrLnDebug :: MonadIO m => Text -> m ()
161 let putStrLnDebug :: MonadIO m => Text -> m ()
141 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
162 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
142− session' = sessionWith wdConfig "" . using (map (,"") caps)
163+ session' t = sessionWith wdConfig t . using caps
143 runWD m = runWDOptions (WdOptions False) $ do
164 runWD m = runWDOptions (WdOptions False) $ do
144 putStrLnDebug "before"
165 putStrLnDebug "before"
@@ -148,10 +169,10 @@ tests withDebugging wdConfig caps _selenium = do
148 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
169 testWidgetStatic :: WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
149 testWidgetStatic = testWidgetStaticDebug withDebugging
170 testWidgetStatic = testWidgetStaticDebug withDebugging
150 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
171 testWidget :: WD () -> WD b -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
151− testWidget = testWidgetDebug withDebugging
172+ testWidget = testWidgetDebug True withDebugging
152 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
173 testWidget' :: WD a -> (a -> WD b) -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ()) -> WD b
153− testWidget' = testWidgetDebug' withDebugging
174+ testWidget' = testWidgetDebug' True withDebugging
154− describe "text" $ session' $ do
175+ session' "text" $ do
155 it "works" $ runWD $ do
176 it "works" $ runWD $ do
156 testWidgetStatic (checkBodyText "hello world") $ do
177 testWidgetStatic (checkBodyText "hello world") $ do
157 text "hello world"
178 text "hello world"
@@ -212,7 +233,7 @@ tests withDebugging wdConfig caps _selenium = do
212 click <- button ""
233 click <- button ""
213 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
234 void $ textNode $ TextNodeConfig "initial" $ Just $ "after" <$ click
215− describe "element" $ session' $ do
236+ session' "element" $ do
216 it "works with domEvent Click" $ runWD $ do
237 it "works with domEvent Click" $ runWD $ do
217 clickedRef <- liftIO $ newRef False
238 clickedRef <- liftIO $ newRef False
218 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
239 testWidget' (findElemWithRetry $ WD.ByTag "div") WD.click $ do
@@ -276,21 +297,78 @@ tests withDebugging wdConfig caps _selenium = do
276 let click = domEvent Click e
297 let click = domEvent Click e
277 return ()
298 return ()
279− describe "inputElement" $ do
300+ session' "inputElement" $ do
301+ describe "static renderer" $ 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)
280− describe "hydration" $ session' $ do
358+ describe "hydration" $ do
281 it "doesn't wipe user input when switching over" $ runWD $ do
359 it "doesn't wipe user input when switching over" $ runWD $ do
282− inputRef <- newRef ("" :: Text)
360+ inputRef <- newRef ("hello " :: Text)
283 testWidget'
361 testWidget'
285 e <- findElemWithRetry $ WD.ByTag "input"
363 e <- findElemWithRetry $ WD.ByTag "input"
286− WD.sendKeys "hello world" e
364+ WD.sendKeys "world" e
288 (\e -> do
366 (\e -> do
289 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
367 WD.attr e "value" `shouldBeWithRetryM` Just "hello world"
290 WD.click =<< findElemWithRetry (WD.ByTag "button")
368 WD.click =<< findElemWithRetry (WD.ByTag "button")
291 readRef inputRef `shouldBeWithRetryM` "hello world"
369 readRef inputRef `shouldBeWithRetryM` "hello world"
293− e <- inputElement def
371+ e <- inputElement $ def & inputElementConfig_initialValue .~ "hello "
294 click <- button "save"
372 click <- button "save"
295 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
373 performEvent_ $ liftIO . writeRef inputRef <$> tag (current (value e)) click
296 it "captures user input after switchover" $ runWD $ do
374 it "captures user input after switchover" $ runWD $ do
@@ -347,24 +425,49 @@ tests withDebugging wdConfig caps _selenium = do
347 checkedByUIRef <- newRef False
425 checkedByUIRef <- newRef False
348 checkedRef <- newRef False
426 checkedRef <- newRef False
349 setCheckedChan <- liftIO newChan
427 setCheckedChan <- liftIO newChan
428+ let checkStatic = do
429+ e <- findElemWithRetry $ WD.ByTag "input"
430+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
350− let checkValue = do
432+ checkValue e = do
351 readRef checkedByUIRef `shouldBeWithRetryM` False
433 readRef checkedByUIRef `shouldBeWithRetryM` False
352 readRef checkedRef `shouldBeWithRetryM` False
434 readRef checkedRef `shouldBeWithRetryM` False
353− e <- findElemWithRetry $ WD.ByTag "input"
435+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
354 WD.moveToCenter e
436 WD.moveToCenter e
355 WD.click e
437 WD.click e
356 readRef checkedByUIRef `shouldBeWithRetryM` True
438 readRef checkedByUIRef `shouldBeWithRetryM` True
357 readRef checkedRef `shouldBeWithRetryM` True
439 readRef checkedRef `shouldBeWithRetryM` True
440+ WD.attr e "checked" `shouldBeWithRetryM` Just "true"
358 liftIO $ writeChan setCheckedChan False
441 liftIO $ writeChan setCheckedChan False
359 readRef checkedByUIRef `shouldBeWithRetryM` True
442 readRef checkedByUIRef `shouldBeWithRetryM` True
360 readRef checkedRef `shouldBeWithRetryM` False
443 readRef checkedRef `shouldBeWithRetryM` False
444+ WD.attr e "checked" `shouldBeWithRetryM` Nothing
361− testWidget (pure ()) checkValue $ do
445+ testWidget' checkStatic checkValue $ do
362 setChecked <- triggerEventWithChan setCheckedChan
446 setChecked <- triggerEventWithChan setCheckedChan
363 e <- inputElement $ def
447 e <- inputElement $ def
364 & initialAttributes .~ "type" =: "checkbox"
448 & initialAttributes .~ "type" =: "checkbox"
365 & inputElementConfig_setChecked .~ setChecked
449 & inputElementConfig_setChecked .~ setChecked
366 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
450 performEvent_ $ liftIO . writeRef checkedByUIRef <$> _inputElement_checkedChange e
367 performEvent_ $ liftIO . writeRef checkedRef <$> updated (_inputElement_checked e)
451 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)
368 it "captures file uploads" $ runWD $ do
471 it "captures file uploads" $ runWD $ do
369 filesRef :: IORef [Text] <- newRef []
472 filesRef :: IORef [Text] <- newRef []
370 let uploadFile = do
473 let uploadFile = do
@@ -380,8 +483,117 @@ tests withDebugging wdConfig caps _selenium = do
380 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
483 prerender_ (pure ()) $ performEvent_ $ ffor (tag (current (_inputElement_files e)) click) $ \fs -> do
381 names <- liftJSM $ traverse File.getName fs
484 names <- liftJSM $ traverse File.getName fs
382 liftIO $ writeRef filesRef names
485 liftIO $ writeRef filesRef names
383−
486+ it "fires _input event if the user altered the value before hydration" $ runWD $ do
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
384− describe "hydration/immediate" $ session' $ do
596+ describe "hydration/immediate" $ do
385 it "captures user input after switchover" $ runWD $ do
597 it "captures user input after switchover" $ runWD $ do
386 inputRef :: IORef Text <- newRef ""
598 inputRef :: IORef Text <- newRef ""
387 let checkValue = do
599 let checkValue = do
@@ -461,8 +673,31 @@ tests withDebugging wdConfig caps _selenium = do
461 names <- liftJSM $ traverse File.getName fs
673 names <- liftJSM $ traverse File.getName fs
462 liftIO $ writeRef filesRef names
674 liftIO $ writeRef filesRef names
464− describe "textAreaElement" $ do
676+ session' "textAreaElement" $ do
465− describe "hydration" $ session' $ 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
466 it "doesn't wipe user input when switching over" $ runWD $ do
701 it "doesn't wipe user input when switching over" $ runWD $ do
467 inputRef <- newRef ("" :: Text)
702 inputRef <- newRef ("" :: Text)
468 testWidget'
703 testWidget'
@@ -528,8 +763,90 @@ tests withDebugging wdConfig caps _selenium = do
528 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
763 e <- textAreaElement $ def { _textAreaElementConfig_setValue = Just setValue' }
529 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
764 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
530 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
765 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
532− describe "hydration/immediate" $ session' $ do
849+ describe "hydration/immediate" $ do
533 it "captures user input after switchover" $ runWD $ do
850 it "captures user input after switchover" $ runWD $ do
534 inputRef :: IORef Text <- newRef ""
851 inputRef :: IORef Text <- newRef ""
535 let checkValue = do
852 let checkValue = do
@@ -571,13 +888,13 @@ tests withDebugging wdConfig caps _selenium = do
571 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
888 performEvent_ $ liftIO . writeRef valueByUIRef <$> _textAreaElement_input e
572 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
889 performEvent_ $ liftIO . writeRef valueRef <$> updated (value e)
574− describe "selectElement" $ do
891+ session' "selectElement" $ do
575 let options :: DomBuilder t m => m ()
892 let options :: DomBuilder t m => m ()
576 options = do
893 options = do
577 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
894 elAttr "option" ("value" =: "one" <> "id" =: "one") $ text "one"
578 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
895 elAttr "option" ("value" =: "two" <> "id" =: "two") $ text "two"
579 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
896 elAttr "option" ("value" =: "three" <> "id" =: "three") $ text "three"
580− describe "hydration" $ session' $ do
897+ describe "hydration" $ do
581 it "sets initial value correctly" $ runWD $ do
898 it "sets initial value correctly" $ runWD $ do
582 inputRef <- newRef ("" :: Text)
899 inputRef <- newRef ("" :: Text)
583 let setup = do
900 let setup = do
@@ -651,7 +968,7 @@ tests withDebugging wdConfig caps _selenium = do
651 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
968 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
652 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
969 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
654− describe "hydration/immediate" $ session' $ do
971+ describe "hydration/immediate" $ do
655 it "captures user input after switchover" $ runWD $ do
972 it "captures user input after switchover" $ runWD $ do
656 inputRef :: IORef Text <- newRef ""
973 inputRef :: IORef Text <- newRef ""
657 let checkValue = do
974 let checkValue = do
@@ -697,7 +1014,7 @@ tests withDebugging wdConfig caps _selenium = do
697 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
1014 performEvent_ $ liftIO . writeRef valueByUIRef <$> _selectElement_change e
698 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
1015 performEvent_ $ liftIO . writeRef valueRef <$> updated (_selectElement_value e)
700− describe "prerender" $ session' $ do
1017+ session' "prerender" $ do
701 it "works in simple case" $ runWD $ do
1018 it "works in simple case" $ runWD $ do
702 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
1019 testWidget (checkBodyText "One") (checkBodyText "Two") $ do
703 prerender_ (text "One") (text "Two")
1020 prerender_ (text "One") (text "Two")
@@ -766,7 +1083,16 @@ tests withDebugging wdConfig caps _selenium = do
766 prerender_ (pure ()) (liftIO $ trigger "Client")
1083 prerender_ (pure ()) (liftIO $ trigger "Client")
767 textNode $ TextNodeConfig "Initial" $ Just e
1084 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 ()
769− describe "runWithReplace" $ session' $ do
1095+ session' "runWithReplace" $ do
770 it "works" $ runWD $ do
1096 it "works" $ runWD $ do
771 replaceChan :: Chan Text <- liftIO newChan
1097 replaceChan :: Chan Text <- liftIO newChan
772 let setup = findElemWithRetry $ WD.ByTag "div"
1098 let setup = findElemWithRetry $ WD.ByTag "div"
@@ -910,7 +1236,61 @@ tests withDebugging wdConfig caps _selenium = do
910 , el "span" . text <$> replace
1236 , 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
913− describe "traverseDMapWithKeyWithAdjust" $ session' $ do
1293+ session' "traverseDMapWithKeyWithAdjust" $ do
914 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
1294 let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
915 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
1295 widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
916 elClass "span" "key" $ text $ textKey k
1296 elClass "span" "key" $ text $ textKey k
@@ -1013,7 +1393,7 @@ tests withDebugging wdConfig caps _selenium = do
1013 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1393 (dmap, _evt) <- traverseDMapWithKeyWithAdjust widget keyMap $ leftmost [postBuildPatch <$ pb, replace]
1014 liftIO $ dmap `H.shouldBe` keyMap
1394 liftIO $ dmap `H.shouldBe` keyMap
1016− describe "traverseIntMapWithKeyWithAdjust" $ session' $ do
1396+ session' "traverseIntMapWithKeyWithAdjust" $ do
1017 let textKeyInt k = "key" <> T.pack (show k)
1397 let textKeyInt k = "key" <> T.pack (show k)
1018 intMap = IntMap.fromList
1398 intMap = IntMap.fromList
1019 [ (1, "one")
1399 [ (1, "one")
@@ -1120,7 +1500,7 @@ tests withDebugging wdConfig caps _selenium = do
1120 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1500 (dmap, _evt) <- traverseIntMapWithKeyWithAdjust widget intMap $ leftmost [postBuildPatch <$ pb, replace]
1121 liftIO $ dmap `H.shouldBe` intMap
1501 liftIO $ dmap `H.shouldBe` intMap
1123− describe "traverseDMapWithKeyWithAdjustWithMove" $ session' $ do
1503+ session' "traverseDMapWithKeyWithAdjustWithMove" $ do
1124 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1504 let widget :: DomBuilder t m => Key2 a -> Identity a -> m (Identity a)
1125 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1505 widget k (Identity v) = elAttr "li" ("id" =: textKey2 k) $ do
1126 elClass "span" "key" $ text $ textKey2 k
1506 elClass "span" "key" $ text $ textKey2 k
@@ -1200,12 +1580,14 @@ tests withDebugging wdConfig caps _selenium = do
1200 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1580 (dmap, _evt) <- traverseDMapWithKeyWithAdjustWithMove widget initMap =<< triggerEventWithChan chan
1201 liftIO $ assertEqual "DMap" initMap dmap
1581 liftIO $ assertEqual "DMap" initMap dmap
1203− describe "hydrating invalid HTML" $ session' $ do
1583+ session' "hydrating invalid HTML" $ do
1204− it "can hydrate list in paragraph" $ runWD $ do
1584+ xit "can hydrate list in paragraph" $ runWD $ do
1205 let preSwitchover = do
1585 let preSwitchover = do
1206 checkBodyText "before\ninner\nafter"
1586 checkBodyText "before\ninner\nafter"
1207 -- Two <p> tags should be present
1587 -- Two <p> tags should be present
1208− [p1, p2] <- WD.findElems (WD.ByTag "p")
1588+ (p1, p2) <- WD.findElems (WD.ByTag "p") >>= \case
1589+ [p1, p2] -> pure (p1, p2)
1590+ _ -> error "Unexpected number of `p` tags (expected 2)"
1209 ol <- findElemWithRetry (WD.ByTag "ol")
1591 ol <- findElemWithRetry (WD.ByTag "ol")
1210 shouldContainText "before" p1
1592 shouldContainText "before" p1
1211 shouldContainText "inner" ol
1593 shouldContainText "inner" ol
@@ -1216,7 +1598,8 @@ tests withDebugging wdConfig caps _selenium = do
1216 shouldContainText "before\ninner\nafter" p1
1598 shouldContainText "before\ninner\nafter" p1
1217 elementShouldBeRemoved ol
1599 elementShouldBeRemoved ol
1218 elementShouldBeRemoved p2
1600 elementShouldBeRemoved p2
1601+ -- Don't fail fatally when hydration encounters the invalid DOM
1219− testWidget' preSwitchover check $ do
1602+ testWidgetDebug' False withDebugging preSwitchover check $ do
1220 -- This is deliberately invalid HTML, the browser will interpret it as
1603 -- This is deliberately invalid HTML, the browser will interpret it as
1221 -- <p>before</p><ol>inner</ol>after<p></p>
1604 -- <p>before</p><ol>inner</ol>after<p></p>
1222 el "p" $ do
1605 el "p" $ do
@@ -1224,6 +1607,29 @@ tests withDebugging wdConfig caps _selenium = do
1224 el "ol" $ text "inner"
1607 el "ol" $ text "inner"
1225 text "after"
1608 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"
1227data Selenium = Selenium
1633data Selenium = Selenium
1228 { _selenium_portNumber :: PortNumber
1634 { _selenium_portNumber :: PortNumber
1229 , _selenium_stopServer :: IO ()
1635 , _selenium_stopServer :: IO ()
@@ -1291,6 +1697,9 @@ checkTextInId i expected = do
1291findElemWithRetry :: Selector -> WD WD.Element
1697findElemWithRetry :: Selector -> WD WD.Element
1292findElemWithRetry = withRetry . WD.findElem
1698findElemWithRetry = withRetry . WD.findElem
1700+findElemsWithRetry :: Selector -> WD [WD.Element]
1701+findElemsWithRetry = withRetry . WD.findElems
1294getBody :: WD WD.Element
1703getBody :: WD WD.Element
1295getBody = WD.findElem $ WD.ByTag "body"
1704getBody = WD.findElem $ WD.ByTag "body"
@@ -1299,8 +1708,8 @@ withRetry a = wait 300
1299 where wait :: Int -> WD a
1708 where wait :: Int -> WD a
1300 wait 0 = a
1709 wait 0 = a
1301 wait n = try a >>= \case
1710 wait n = try a >>= \case
1302− Left (_ :: SomeException) -> do
1711+ Left (e :: SomeException) -> do
1303− liftIO $ threadDelay 100000
1712+ liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
1304 wait $ n - 1
1713 wait $ n - 1
1305 Right v -> return v
1714 Right v -> return v
@@ -1316,11 +1725,12 @@ testWidgetStaticDebug
1316 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1725 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1317 -- ^ Widget we are testing
1726 -- ^ Widget we are testing
1319−testWidgetStaticDebug withDebugging w = testWidgetDebug withDebugging (void w) w
1728+testWidgetStaticDebug withDebugging w = testWidgetDebug True withDebugging (void w) w
1321-- | TODO: do something about JSExceptions not causing tests to fail
1730-- | TODO: do something about JSExceptions not causing tests to fail
1322testWidgetDebug
1731testWidgetDebug
1324 -> WD ()
1734 -> WD ()
1325 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1735 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
@@ -1328,12 +1738,16 @@ testWidgetDebug
1328 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1738 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1329 -- ^ Widget we are testing
1739 -- ^ Widget we are testing
1331−testWidgetDebug withDebugging beforeJS afterSwitchover =
1741+testWidgetDebug hardFailure withDebugging beforeJS afterSwitchover =
1332− testWidgetDebug' withDebugging beforeJS (const afterSwitchover)
1742+ testWidgetDebug' hardFailure withDebugging beforeJS (const afterSwitchover)
1744+data HydrationFailedException = HydrationFailedException deriving Show
1745+instance Exception HydrationFailedException
1334-- | TODO: do something about JSExceptions not causing tests to fail
1747-- | TODO: do something about JSExceptions not causing tests to fail
1335testWidgetDebug'
1748testWidgetDebug'
1338 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1752 -- ^ Webdriver commands to run before the JS runs (i.e. on the statically rendered page)
1339 -> (a -> WD b)
1753 -> (a -> WD b)
@@ -1341,7 +1755,7 @@ testWidgetDebug'
1341 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1755 -> (forall m js. TestWidget js (SpiderTimeline Global) m => m ())
1342 -- ^ Widget we are testing (contents of body)
1756 -- ^ Widget we are testing (contents of body)
1344−testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1758+testWidgetDebug' hardFailure withDebugging beforeJS afterSwitchover bodyWidget = do
1345 let putStrLnDebug :: MonadIO m => Text -> m ()
1759 let putStrLnDebug :: MonadIO m => Text -> m ()
1346 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1760 putStrLnDebug m = when withDebugging $ liftIO $ putStrLn $ T.unpack m
1347 staticApp = do
1761 staticApp = do
@@ -1349,10 +1763,11 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1349 el "body" $ do
1763 el "body" $ do
1350 bodyWidget
1764 bodyWidget
1351 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1765 el "script" $ text $ TE.decodeUtf8 $ LBS.toStrict $ jsaddleJs False
1352− putStrLnDebug "rendering preSwitchover"
1766+ putStrLnDebug "rendering static"
1353− ((), html) <- liftIO $ renderStatic staticApp
1767+ ((), html) <- liftIO $ renderStatic $ runHydratableT staticApp
1354− putStrLnDebug "rendered preSwitchover"
1768+ putStrLnDebug "rendered static"
1355 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1769 waitBeforeJS <- liftIO newEmptyMVar -- Empty until JS should be run
1770+ onFailure <- if hardFailure then (`throwTo` HydrationFailedException) <$> liftIO myThreadId else pure $ pure ()
1356 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1771 waitUntilSwitchover <- liftIO newEmptyMVar -- Empty until switchover
1357 let entryPoint = do
1772 let entryPoint = do
1358 putStrLnDebug "taking waitBeforeJS"
1773 putStrLnDebug "taking waitBeforeJS"
@@ -1364,7 +1779,7 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1364 liftIO $ putMVar waitUntilSwitchover ()
1779 liftIO $ putMVar waitUntilSwitchover ()
1365 putStrLnDebug "put waitUntilSwitchover"
1780 putStrLnDebug "put waitUntilSwitchover"
1366 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1781 putStrLnDebug "running mainHydrationWidgetWithSwitchoverAction"
1367− mainHydrationWidgetWithSwitchoverAction switchOverAction blank bodyWidget
1782+ mainHydrationWidgetWithSwitchoverActionWithFailure' onFailure switchOverAction blank bodyWidget
1368 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1783 putStrLnDebug "syncPoint after mainHydrationWidgetWithSwitchoverAction"
1369 syncPoint
1784 syncPoint
1370 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
1785 application <- liftIO $ jsaddleOr defaultConnectionOptions entryPoint $ \_ sendResponse -> do
@@ -1382,23 +1797,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
1383 -- hSilence to get rid of ConnectionClosed logs
1798 -- hSilence to get rid of ConnectionClosed logs
1384 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1799 silenceIfDebug = if withDebugging then id else hSilence [stderr]
1385− jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
1800+ jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
1386− jsaddleTid <- liftIO jsaddleWarp
1801+ withAsync' jsaddleWarp $ do
1387− putStrLnDebug "taking waitJSaddle"
1802+ putStrLnDebug "taking waitJSaddle"
1388− liftIO $ takeMVar waitJSaddle
1803+ liftIO $ takeMVar waitJSaddle
1389− putStrLnDebug "opening page"
1804+ putStrLnDebug "opening page"
1390− WD.openPage $ "http://localhost:" <> show jsaddlePort
1805+ WD.openPage $ "http://localhost:" <> show jsaddlePort
1391− putStrLnDebug "running beforeJS"
1806+ putStrLnDebug "running beforeJS"
1392− a <- beforeJS
1807+ a <- beforeJS
1393− putStrLnDebug "putting waitBeforeJS"
1808+ putStrLnDebug "putting waitBeforeJS"
1394− liftIO $ putMVar waitBeforeJS ()
1809+ liftIO $ putMVar waitBeforeJS ()
1395− putStrLnDebug "taking waitUntilSwitchover"
1810+ putStrLnDebug "taking waitUntilSwitchover"
1396− liftIO $ takeMVar waitUntilSwitchover
1811+ liftIO $ takeMVar waitUntilSwitchover
1397− putStrLnDebug "running afterSwitchover"
1812+ putStrLnDebug "running afterSwitchover"
1398− b <- afterSwitchover a
1813+ afterSwitchover a
1399− putStrLnDebug "killing jsaddle thread"
1814+
1400− liftIO $ killThread jsaddleTid
1815+withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
1401− return b
1816+withAsync' f g = bracket
1817+ (liftIO $ Async.async f)
1818+ (liftIO . Async.uninterruptibleCancel)
1403data Key2 a where
1821data Key2 a where
1404 Key2_Int :: Int -> Key2 Int
1822 Key2_Int :: Int -> Key2 Int